/* -*- Mode: C; c-basic-offset:4 ; -*- */
/*
*
* (C) 2012 by Argonne National Laboratory.
* See COPYRIGHT in top-level directory.
*/
#include <stdio.h>
#include "mpi.h"
#include <stdlib.h>
#include <string.h>
#include "../../include/mpitestconf.h"
/* Used to convert Fortran strings (which may not be null terminated) to
C strings */
#define MAX_ATTRTEST_MSG 256
/*
* FIXME: This code assumes that character strings are passed from Fortran
* by placing the string length, as an int, at the end of the argument list
* This is common but not universal.
*/
/*
Name mapping. All routines are created with names that are lower case
with a single trailing underscore. This matches many compilers.
We use #define to change the name for Fortran compilers that do
not use the lowercase/underscore pattern
*/
#ifdef F77_NAME_UPPER
#define cattrinit_ CATTRINIT
#define cgetenvbool_ CGETENVBOOL
#define cgetsizes_ CGETSIZES
#define ccreatekeys_ CCREATEKEYS
#define cfreekeys_ CFREEKEYS
#define ctoctest_ CTOCTEST
#define cmpif1read_ CMPIF1READ
#define cmpif2read_ CMPIF2READ
#define cmpif2readtype_ CMPIF2READTYPE
#define cmpif2readwin_ CMPIF2READWIN
#define csetmpi_ CSETMPI
#define csetmpi2_ CSETMPI2
#define csetmpitype_ CSETMPITYPE
#define csetmpiwin_ CSETMPIWIN
#elif defined(F77_NAME_LOWER) || defined(F77_NAME_MIXED)
/* Mixed is ok because we use lowercase in all uses */
#define cattrinit_ cattrinit
#define cgetenvbool_ cgetenvbool
#define cgetsizes_ cgetsizes
#define ccreatekeys_ ccreatekeys
#define cfreekeys_ cfreekeys
#define ctoctest_ ctoctest
#define cmpif1read_ cmpif1read
#define cmpif2read_ cmpif2read
#define cmpif2readtype_ cmpif2readtype
#define cmpif2readwin_ cmpif2readwin
#define csetmpi_ csetmpi
#define csetmpi2_ csetmpi2
#define csetmpitype_ csetmpitype
#define csetmpiwin_ csetmpiwin
#elif defined(F77_NAME_LOWER_2USCORE) || defined(F77_NAME_LOWER_USCORE) || \
defined(F77_NAME_MIXED_USCORE)
/* Else leave name alone (routines have no underscore, so both
of these map to a lowercase, single underscore) */
#else
#error 'Unrecognized Fortran name mapping'
#endif
/* */
static int ccomm1Key, ccomm2Key, ctype2Key, cwin2Key;
static int ccomm1Extra, ccomm2Extra, ctype2Extra, cwin2Extra;
static int verbose = 0;
/* Forward references */
int cmpi1read(MPI_Comm comm, int key, void *expected, const char *msg);
int cmpi2read(MPI_Comm comm, int key, void *expected, const char *msg);
int cmpi2readtype(MPI_Datatype dtype, int key, void *expected, const char *msg);
void ccompareint2aint_(MPI_Fint * in1, MPI_Aint * in2, MPI_Fint * result);
void ccompareint2void_(MPI_Fint * in1, void *in2, MPI_Fint * result);
void ccompareaint2void_(MPI_Aint * in1, void *in2, MPI_Fint * result);
/* ----------------------------------------------------------------------- */
/* Initialization functions */
/* ----------------------------------------------------------------------- */
void cgetenvbool_(const char str[], MPI_Fint * val, int d)
{
const char *envval;
char envname[1024];
/* Note that the Fortran string may not be null terminated; thus
* we copy d characters and add a null just in case */
if (d > sizeof(envname) - 1) {
fprintf(stderr, "Environment variable name too long (%d)\n", d);
MPI_Abort(MPI_COMM_WORLD, 1);
}
strncpy(envname, str, d);
envname[d] = 0;
envval = getenv(envname);
*val = 0;
if (envval) {
printf(" envval = %s\n", envval);
if (strcmp(envval, "yes") == 0 || strcmp(envval, "YES") == 0 ||
strcmp(envval, "true") == 0 || strcmp(envval, "TRUE") == 0)
*val = 1;
}
}
/* Keep our own copy of the "is verbose" state */
void cattrinit_(MPI_Fint * fverbose)
{
verbose = (int) *fverbose;
}
/* Provide attribute sizes (C, Fortran 1, Fortran 2) */
void cgetsizes_(MPI_Fint * ptrSize, MPI_Fint * intSize, MPI_Fint * aintSize)
{
*ptrSize = (MPI_Fint) sizeof(void *);
*intSize = (MPI_Fint) sizeof(MPI_Fint);
*aintSize = (MPI_Fint) sizeof(MPI_Aint);
}
/* ----------------------------------------------------------------------- */
/* Copy and delete functions attached to keyvals */
/* ----------------------------------------------------------------------- */
static int CMPI1_COPY_FN(MPI_Comm comm, int keyval, void *extra,
void *inval, void *outval, int *flag)
{
int inValue = *(int *) inval;
if (verbose)
printf(" In C MPI-1 copy function: inval = %p, extra = %p\n", inval, extra);
*flag = 1;
/* We don't change the attribute */
*(void **) outval = inval;
/* But we do change what it points at */
*(int *) inval = inValue + 1;
return MPI_SUCCESS;
}
static int CMPI1_DELETE_FN(MPI_Comm comm, int keyval, void *outval, void *extra)
{
if (verbose)
printf(" In C MPI-1 delete function, extra = %p\n", extra);
*(int *) outval = *(int *) outval - 1;
return MPI_SUCCESS;
}
static int TYPE_COPY_FN(MPI_Datatype dtype, int keyval, void *extra,
void *inval, void *outval, int *flag)
{
int inValue = *(int *) inval;
if (verbose)
printf(" In C MPI type copy function, inval = %p, extra = %p\n", inval, extra);
*flag = 1;
/* We don't change the attribute */
*(void **) outval = inval;
/* But we do change what it points at */
*(int *) inval = inValue + 1;
return MPI_SUCCESS;
}
static int TYPE_DELETE_FN(MPI_Datatype dtype, int keyval, void *outval, void *extra)
{
if (verbose)
printf(" In C MPI type delete function, extra = %p\n", extra);
/* We reverse the incrment used in copy (checked after free of the type) */
*(int *) outval = *(int *) outval - 1;
return MPI_SUCCESS;
}
/* Note that this function cannot be called in MPI since there is no
win_dup function */
static int WIN_COPY_FN(MPI_Win win, int keyval, void *extra, void *inval, void *outval, int *flag)
{
int inValue = *(int *) inval;
if (verbose)
printf("PANIC: In C MPI win copy function (should never happen)\n");
*flag = 1;
return MPI_SUCCESS;
}
static int WIN_DELETE_FN(MPI_Win win, int keyval, void *outval, void *extra)
{
if (verbose)
printf(" In C MPI win delete function, extra = %p\n", extra);
*(int *) outval = *(int *) outval - 1;
return MPI_SUCCESS;
}
/* ----------------------------------------------------------------------- */
/* Routines to create keyvals in C (with C copy and delete functions */
/* ----------------------------------------------------------------------- */
void ccreatekeys_(MPI_Fint * ccomm1_key, MPI_Fint * ccomm2_key,
MPI_Fint * ctype2_key, MPI_Fint * cwin2_key)
{
MPI_Keyval_create(CMPI1_COPY_FN, CMPI1_DELETE_FN, &ccomm1Key, &ccomm1Extra);
*ccomm1_key = (MPI_Fint) ccomm1Key;
MPI_Comm_create_keyval(CMPI1_COPY_FN, CMPI1_DELETE_FN, &ccomm2Key, &ccomm2Extra);
*ccomm2_key = (MPI_Fint) ccomm2Key;
MPI_Type_create_keyval(TYPE_COPY_FN, TYPE_DELETE_FN, &ctype2Key, &ctype2Extra);
*ctype2_key = (MPI_Fint) ctype2Key;
MPI_Win_create_keyval(WIN_COPY_FN, WIN_DELETE_FN, &cwin2Key, &cwin2Extra);
*cwin2_key = (MPI_Fint) cwin2Key;
}
void cfreekeys_(void)
{
MPI_Keyval_free(&ccomm1Key);
MPI_Comm_free_keyval(&ccomm2Key);
MPI_Type_free_keyval(&ctype2Key);
MPI_Win_free_keyval(&cwin2Key);
}
/* ----------------------------------------------------------------------- */
/* ----------------------------------------------------------------------- */
/* Test c-to-c attributes */
static int ccomm1Attr, ccomm2Attr, ctype2Attr, cwin2Attr;
void ctoctest_(MPI_Fint * errs)
{
int errcnt = *errs;
int baseattrval = (1 << (sizeof(int) * 8 - 2)) - 3;
MPI_Datatype cduptype;
MPI_Comm cdup;
/* MPI-1 function */
ccomm1Attr = baseattrval;
MPI_Attr_put(MPI_COMM_SELF, ccomm1Key, &ccomm1Attr);
/* Test that we have the same value */
errcnt += cmpi1read(MPI_COMM_SELF, ccomm1Key, &ccomm1Attr, "C to C");
/* Dup, check that the copy routine does what is expected */
MPI_Comm_dup(MPI_COMM_SELF, &cdup);
errcnt += cmpi1read(cdup, ccomm1Key, &ccomm1Attr, "C to C dup");
if (ccomm1Attr != baseattrval + 1) {
printf(" Did not increment int in C to C dup: %d %d\n", ccomm1Attr, baseattrval + 1);
errcnt++;
}
MPI_Comm_free(&cdup);
if (ccomm1Attr != baseattrval) {
printf(" Did not increment int in C to C delete: %d %d\n", ccomm1Attr, baseattrval);
errcnt++;
}
/* MPI-2 functions */
ccomm1Attr = 0;
ccomm2Attr = baseattrval;
MPI_Comm_set_attr(MPI_COMM_SELF, ccomm2Key, &ccomm2Attr);
/* Test that we have the same value */
errcnt += cmpi2read(MPI_COMM_SELF, ccomm2Key, &ccomm2Attr, "C to C (2)");
/* Dup, check that the copy routine does what is expected */
MPI_Comm_dup(MPI_COMM_SELF, &cdup);
errcnt += cmpi2read(cdup, ccomm2Key, &ccomm2Attr, "C to C dup (2)");
if (ccomm2Attr != baseattrval + 1) {
printf(" Did not increment int in C to C dup: %d %d\n", ccomm2Attr, baseattrval + 1);
errcnt++;
}
MPI_Comm_free(&cdup);
if (ccomm2Attr != baseattrval) {
printf(" Did not increment int in C to C delete (2): %d %d\n", ccomm2Attr, baseattrval);
errcnt++;
}
/* MPI-2 functions */
ctype2Attr = baseattrval;
MPI_Type_set_attr(MPI_INTEGER, ctype2Key, &ctype2Attr);
/* Test that we have the same value */
errcnt += cmpi2readtype(MPI_INTEGER, ctype2Key, &ctype2Attr, "C to C type (2)");
/* Dup, check that the copy routine does what is expected */
MPI_Type_dup(MPI_INTEGER, &cduptype);
errcnt += cmpi2readtype(cduptype, ctype2Key, &ctype2Attr, "C to C typedup (2)");
if (ctype2Attr != baseattrval + 1) {
printf(" Did not increment int in C to C typedup: %d %d\n", ctype2Attr, baseattrval + 1);
errcnt++;
}
ccomm1Attr = 0;
MPI_Type_free(&cduptype);
if (ctype2Attr != baseattrval) {
printf(" Did not increment int in C to C typedelete (2): %d %d\n", ctype2Attr, baseattrval);
errcnt++;
}
*errs = errcnt;
}
/* ----------------------------------------------------------------------- */
/* Routines to get and check an attribute value. Returns the number */
/* of errors found */
/* ----------------------------------------------------------------------- */
int cmpi1read(MPI_Comm comm, int key, void *expected, const char *msg)
{
void *attrval;
int flag;
MPI_Attr_get(comm, key, &attrval, &flag);
if (!flag) {
printf(" Error: flag false for Attr_get: %s\n", msg);
return 1;
}
if (attrval != expected) {
printf(" Error: expected %p but saw %p: %s\n", expected, attrval, msg);
return 1;
}
return 0;
}
int cmpi2read(MPI_Comm comm, int key, void *expected, const char *msg)
{
void *attrval;
int flag;
MPI_Comm_get_attr(comm, key, &attrval, &flag);
if (!flag) {
printf(" Error: flag false for Comm_get_attr: %s\n", msg);
return 1;
}
if (attrval != expected) {
printf(" Error: expected %p but saw %p: %s\n", expected, attrval, msg);
return 1;
}
return 0;
}
int cmpi2readtype(MPI_Datatype dtype, int key, void *expected, const char *msg)
{
void *attrval;
int flag;
MPI_Type_get_attr(dtype, key, &attrval, &flag);
if (!flag) {
printf(" Error: flag false for Type_get_attr: %s\n", msg);
return 1;
}
if (attrval != expected) {
printf(" Error: expected %p but saw %p: %s\n", expected, attrval, msg);
return 1;
}
return 0;
}
int cmpi2readwin(MPI_Win win, int key, void *expected, const char *msg)
{
void *attrval;
int flag;
MPI_Win_get_attr(win, key, &attrval, &flag);
if (!flag) {
printf(" Error: flag false for Win_get_attr: %s\n", msg);
return 1;
}
if (attrval != expected) {
printf(" Error: expected %p but saw %p: %s\n", expected, attrval, msg);
return 1;
}
return 0;
}
/* Set in Fortran (MPI-1), read in C */
void cmpif1read_(MPI_Fint * fcomm, MPI_Fint * fkey, MPI_Fint * expected,
MPI_Fint * errs, const char *msg, int msglen)
{
void *attrval;
int flag, result;
MPI_Comm comm = MPI_Comm_f2c(*fcomm);
char lmsg[MAX_ATTRTEST_MSG];
if (msglen > sizeof(lmsg) - 1) {
fprintf(stderr, "Message too long for buffer (%d)\n", msglen);
MPI_Abort(MPI_COMM_WORLD, 1);
}
MPI_Attr_get(comm, *fkey, &attrval, &flag);
if (!flag) {
*errs = *errs + 1;
strncpy(lmsg, msg, msglen);
lmsg[msglen] = 0;
printf(" Error: flag false for Attr_get (set in F1): %s\n", lmsg);
return;
}
/* Must be careful to compare as required in the MPI specification */
ccompareint2void_(expected, attrval, &result);
if (!result) {
*errs = *errs + 1;
strncpy(lmsg, msg, msglen);
lmsg[msglen] = 0;
printf(" Error: (set in F1) expected %d but saw %d: %s\n",
*expected, *(MPI_Fint *) attrval, lmsg);
return;
}
return;
}
/* Set in Fortran (MPI-2), read in C */
void cmpif2read_(MPI_Fint * fcomm, MPI_Fint * fkey, MPI_Aint * expected,
MPI_Fint * errs, const char *msg, int msglen)
{
void *attrval;
int flag, result;
MPI_Comm comm = MPI_Comm_f2c(*fcomm);
char lmsg[MAX_ATTRTEST_MSG];
if (msglen > sizeof(lmsg) - 1) {
fprintf(stderr, "Message too long for buffer (%d)\n", msglen);
MPI_Abort(MPI_COMM_WORLD, 1);
}
MPI_Comm_get_attr(comm, *fkey, &attrval, &flag);
if (!flag) {
*errs = *errs + 1;
strncpy(lmsg, msg, msglen);
lmsg[msglen] = 0;
printf(" Error: flag false for Comm_get_attr (set in F2): %s\n", lmsg);
return;
}
ccompareaint2void_(expected, attrval, &result);
if (!result) {
*errs = *errs + 1;
strncpy(lmsg, msg, msglen);
lmsg[msglen] = 0;
printf(" Error: (set in F2) expected %ld but saw %ld: %s\n",
(long) *expected, (long) *(MPI_Aint *) attrval, lmsg);
return;
}
return;
}
void cmpif2readtype_(MPI_Fint * ftype, MPI_Fint * fkey, MPI_Aint * expected,
MPI_Fint * errs, const char *msg, int msglen)
{
void *attrval;
int flag, result;
MPI_Datatype dtype = MPI_Type_f2c(*ftype);
char lmsg[MAX_ATTRTEST_MSG];
if (msglen > sizeof(lmsg) - 1) {
fprintf(stderr, "Message too long for buffer (%d)\n", msglen);
MPI_Abort(MPI_COMM_WORLD, 1);
}
MPI_Type_get_attr(dtype, *fkey, &attrval, &flag);
if (!flag) {
*errs = *errs + 1;
strncpy(lmsg, msg, msglen);
lmsg[msglen] = 0;
printf(" Error: flag false for Type_get_attr (set in F2): %s\n", lmsg);
return;
}
ccompareaint2void_(expected, attrval, &result);
if (!result) {
*errs = *errs + 1;
strncpy(lmsg, msg, msglen);
lmsg[msglen] = 0;
printf(" Error: (set in F2/Type) expected %ld but saw %ld: %s\n",
(long) *expected, (long) *(MPI_Aint *) attrval, lmsg);
return;
}
return;
}
void cmpif2readwin_(MPI_Fint * fwin, MPI_Fint * fkey, MPI_Aint * expected,
MPI_Fint * errs, const char *msg, int msglen)
{
void *attrval;
int flag, result;
MPI_Win win = MPI_Win_f2c(*fwin);
char lmsg[MAX_ATTRTEST_MSG];
if (msglen > sizeof(lmsg) - 1) {
fprintf(stderr, "Message too long for buffer (%d)\n", msglen);
MPI_Abort(MPI_COMM_WORLD, 1);
}
MPI_Win_get_attr(win, *fkey, &attrval, &flag);
if (!flag) {
*errs = *errs + 1;
strncpy(lmsg, msg, msglen);
lmsg[msglen] = 0;
printf(" Error: flag false for Win_get_attr (set in F2): %s\n", lmsg);
return;
}
ccompareaint2void_(expected, attrval, &result);
if (!result) {
*errs = *errs + 1;
strncpy(lmsg, msg, msglen);
lmsg[msglen] = 0;
printf(" Error: (set in F2/Win) expected %ld but saw %ld: %s\n",
(long) *expected, (long) *(MPI_Aint *) attrval, lmsg);
return;
}
return;
}
/* ----------------------------------------------------------------------- */
/* Given a Fortran attribute (pointer to the value to store), set it using */
/* the C attribute functions */
/* ----------------------------------------------------------------------- */
void csetmpi_(MPI_Fint * fcomm, MPI_Fint * fkey, MPI_Fint * val, MPI_Fint * errs)
{
MPI_Comm comm = MPI_Comm_f2c(*fcomm);
MPI_Comm_set_attr(comm, *fkey, (void *) (MPI_Aint) * val);
}
void csetmpi2_(MPI_Fint * fcomm, MPI_Fint * fkey, MPI_Aint * val, MPI_Fint * errs)
{
MPI_Comm comm = MPI_Comm_f2c(*fcomm);
MPI_Comm_set_attr(comm, *fkey, (void *) *val);
}
void csetmpitype_(MPI_Fint * ftype, MPI_Fint * fkey, MPI_Aint * val, MPI_Fint * errs)
{
MPI_Datatype dtype = MPI_Type_f2c(*ftype);
MPI_Type_set_attr(dtype, *fkey, (void *) *val);
}
void csetmpiwin_(MPI_Fint * fwin, MPI_Fint * fkey, MPI_Aint * val, MPI_Fint * errs)
{
MPI_Win win = MPI_Win_f2c(*fwin);
MPI_Win_set_attr(win, *fkey, (void *) *val);
}
/* ----------------------------------------------------------------------- */
/* Comparisons */
/* int with aint */
/* int with void* */
/* aint with void* */
/* All routines use similar interfaces, though the routines that involve */
/* void * must be called from C */
/* Defined to be callable from either C or Fortran */
/* Here is the rule, defined in the MPI standard: */
/* If one item is shorter than the other, take the low bytes. */
/* If one item is longer than the other, sign extend */
/* ----------------------------------------------------------------------- */
void ccompareint2aint_(MPI_Fint * in1, MPI_Aint * in2, MPI_Fint * result)
{
static int idx = -1;
if (sizeof(MPI_Fint) == sizeof(MPI_Aint)) {
*result = *in1 == *in2;
} else if (sizeof(MPI_Fint) < sizeof(MPI_Aint)) {
/* Assume Aint no smaller than Fint, and that size of aint
* is a multiple of the size of fint) */
MPI_Fint *v2 = (MPI_Fint *) in2;
if (idx < 0) {
MPI_Aint av = 1;
MPI_Fint *fa = (MPI_Fint *) & av;
if ((sizeof(MPI_Aint) % sizeof(MPI_Fint)) != 0) {
fprintf(stderr,
"PANIC: size of MPI_Aint = %d not a multiple of MPI_Fint = %d\n",
(int) sizeof(MPI_Aint), (int) sizeof(MPI_Fint));
MPI_Abort(MPI_COMM_WORLD, 1);
}
for (idx = sizeof(MPI_Aint) / sizeof(MPI_Fint); idx >= 0; idx--)
if (fa[idx])
break;
if (idx < 0) {
fprintf(stderr, "Unable to determine low word of Fint in Aint\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
*result = *in1 == v2[idx];
}
} else {
fprintf(stderr, "PANIC: sizeof(MPI_Fint) = %d > sizeof(MPI_Aint) %d\n",
(int) sizeof(MPI_Fint), (int) sizeof(MPI_Aint));
MPI_Abort(MPI_COMM_WORLD, 1);
}
}
void ccompareint2void_(MPI_Fint * in1, void *in2, MPI_Fint * result)
{
static int idx = -1;
if (sizeof(MPI_Fint) == sizeof(void *)) {
*result = *in1 == *(MPI_Fint *) in2;
} else if (sizeof(MPI_Fint) < sizeof(void *)) {
/* Assume void* no smaller than Fint, and that size of aint
* is a multiple of the size of fint) */
MPI_Fint *v2 = (MPI_Fint *) in2;
if (idx < 0) {
void *av = (void *) 1;
MPI_Fint *fa = (MPI_Fint *) & av;
if ((sizeof(void *) % sizeof(MPI_Fint)) != 0) {
fprintf(stderr,
"PANIC: size of void * = %d not a multiple of MPI_Fint = %d\n",
(int) sizeof(void *), (int) sizeof(MPI_Fint));
MPI_Abort(MPI_COMM_WORLD, 1);
}
for (idx = sizeof(void *) / sizeof(MPI_Fint); idx >= 0; idx--)
if (fa[idx])
break;
if (idx < 0) {
fprintf(stderr, "Unable to determine low word of Fint in void*\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
*result = *in1 == v2[idx];
}
} else {
fprintf(stderr, "PANIC: sizeof(MPI_Fint) = %d > sizeof(void*) %d\n",
(int) sizeof(MPI_Fint), (int) sizeof(void *));
MPI_Abort(MPI_COMM_WORLD, 1);
}
}
void ccompareaint2void_(MPI_Aint * in1, void *in2, MPI_Fint * result)
{
/* Note that an aint must be >= void * by definition */
*result = *in1 == *(MPI_Aint *) in2;
}