Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

#172 Fix calling functions with value arguments in co_reduce #331

Closed
wants to merge 2 commits into from
Closed

#172 Fix calling functions with value arguments in co_reduce #331

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
b7fc3ff
Add value- and char-array support to co_reduce functions.
Feb 8, 2017
973cacf
Improved cleanup of co_broadcast. Fixed co_reduce_string testcase.
vehre Feb 8, 2017
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 4 additions & 1 deletion CMakeLists.txt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -442,8 +442,11 @@ if(opencoarrays_aware_compiler)
add_mpi_test(convert-before-put 3 ${tests_root}/regression/reported/convert-before-put)
add_mpi_test(event-post 3 ${tests_root}/regression/reported/event-post)
add_mpi_test(co_reduce-factorial 4 ${tests_root}/regression/reported/co_reduce-factorial)
add_mpi_test(co_reduce-factorial-int8 4 ${tests_root}/regression/reported/co_reduce-factorial-int8)
add_mpi_test(co_reduce-factorial-int64 4 ${tests_root}/regression/reported/co_reduce-factorial-int64)
add_mpi_test(co_reduce_string 4 ${tests_root}/unit/collectives/co_reduce_string)
# remove this before merging into master
set_property(TEST co_reduce-factorial PROPERTY WILL_FAIL TRUE)
# set_property(TEST co_reduce-factorial PROPERTY WILL_FAIL TRUE)
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Just delete this line entirely please.

else()
add_test(co_sum_extension ${tests_root}/unit/extensions/test-co_sum-extension.sh)
set_property(TEST co_sum_extension PROPERTY PASS_REGULAR_EXPRESSION "Test passed.")
Expand Down
7 changes: 7 additions & 0 deletions src/libcaf.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -197,6 +197,13 @@ typedef struct caf_reference_t {
#endif


/* The following defines give the bits in the opr_flags argument to CO_REDUCE.
Keep in sync with the libgfortran.h file of gcc/fortran. */
#define GFC_CAF_BYREF (1<<0)
#define GFC_CAF_HIDDENLEN (1<<1)
#define GFC_CAF_ARG_VALUE (1<<2)
#define GFC_CAF_ARG_DESC (1<<3)

/* Common auxiliary functions: caf_auxiliary.c. */

bool PREFIX (is_contiguous) (gfc_descriptor_t *);
Expand Down
155 changes: 118 additions & 37 deletions src/mpi/mpi_caf.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -141,10 +141,17 @@ MPI_Comm CAF_COMM_WORLD;
(and thus finalization) of MPI. */
bool caf_owns_mpi = false;

/* Foo function pointers for coreduce */
int (*foo_int32_t)(void *, void *);
float (*foo_float)(void *, void *);
double (*foo_double)(void *, void *);
/* Foo function pointers for coreduce.
The handles when arguments are passed by reference. */
int (*int32_t_by_reference)(void *, void *);
float (*float_by_reference)(void *, void *);
double (*double_by_reference)(void *, void *);
/* Strings are always passed by reference. */
void (*char_by_reference)(void *, int, void *, void *, int, int);
/* The handles when arguments are passed by value. */
int (*int32_t_by_value)(int32_t, int32_t);
float (*float_by_value)(float, float);
double (*double_by_value)(double, double);

/* Define shortcuts for Win_lock and _unlock depending on whether the primitives
are available in the MPI implementation. When they are not available the
Expand Down Expand Up @@ -3125,17 +3132,29 @@ name (datatype *invec, datatype *inoutvec, int *len, \
operator; \
}

#define FOOFUNC(TYPE) foo_ ## TYPE
#define REFERENCE_FUNC(TYPE) TYPE ## _by_reference
#define VALUE_FUNC(TYPE) TYPE ## _by_value

#define GEN_COREDUCE(name, dt) \
static void \
name (void *invec, void *inoutvec, int *len, \
name##_by_reference_adapter (void *invec, void *inoutvec, int *len, \
MPI_Datatype *datatype) \
{ \
int i; \
for(i=0;i<*len;i++) \
{ \
*((dt*)inoutvec) = (dt)(FOOFUNC(dt)((dt *)invec,(dt *)inoutvec)); \
*((dt*)inoutvec) = (dt)(REFERENCE_FUNC(dt)((dt *)invec, (dt *)inoutvec)); \
invec+=sizeof(dt); inoutvec+=sizeof(dt); \
} \
} \
static void \
name##_by_value_adapter (void *invec, void *inoutvec, int *len, \
MPI_Datatype *datatype) \
{ \
int i; \
for(i=0;i<*len;i++) \
{ \
*((dt*)inoutvec) = (dt)(VALUE_FUNC(dt)(*(dt *)invec, *(dt *)inoutvec)); \
invec+=sizeof(dt); inoutvec+=sizeof(dt); \
} \
}
Expand All @@ -3144,6 +3163,22 @@ GEN_COREDUCE (redux_int32, int32_t)
GEN_COREDUCE (redux_real32, float)
GEN_COREDUCE (redux_real64, double)

static void \
redux_char_by_reference_adapter (void *invec, void *inoutvec, int *len,
MPI_Datatype *datatype)
{
long int string_len;
MPI_Type_extent(*datatype, &string_len);
for(int i = 0; i < *len; i++)
{
/* The length of the result is fixed, i.e., no deferred string length is
* allowed there. */
REFERENCE_FUNC(char)((char *)inoutvec, string_len, (char *)invec, (char *)inoutvec, string_len, string_len);
invec += sizeof(char) * string_len;
inoutvec += sizeof(char) * string_len;
}
}

#ifndef MPI_INTEGER1
GEN_REDUCTION (do_sum_int1, int8_t, inoutvec[i] += invec[i])
GEN_REDUCTION (do_min_int1, int8_t,
Expand Down Expand Up @@ -3198,7 +3233,7 @@ GEN_REDUCTION (do_max_complex10, _Complex __float128,


static MPI_Datatype
get_MPI_datatype (gfc_descriptor_t *desc)
get_MPI_datatype (gfc_descriptor_t *desc, int char_len)
{
/* FIXME: Better check whether the sizes are okay and supported;
MPI3 adds more types, e.g. MPI_INTEGER1. */
Expand Down Expand Up @@ -3255,22 +3290,29 @@ get_MPI_datatype (gfc_descriptor_t *desc)
GFC_DTYPE_TYPE_SIZE == GFC_TYPE_CHARACTER + 64*strlen
*/
if ( (GFC_DTYPE_TYPE_SIZE(desc)-GFC_DTYPE_CHARACTER)%64==0 )
return MPI_CHARACTER;
{
MPI_Datatype string;
if (char_len == 0)
char_len = GFC_DESCRIPTOR_SIZE (desc);
MPI_Type_contiguous(char_len, MPI_CHARACTER, &string);
MPI_Type_commit(&string);
return string;
}

caf_runtime_error ("Unsupported data type in collective: %ld\n",GFC_DTYPE_TYPE_SIZE (desc));
return 0;
}


static void
co_reduce_1 (MPI_Op op, gfc_descriptor_t *source, int result_image, int *stat,
char *errmsg, int src_len __attribute__ ((unused)), int errmsg_len)
internal_co_reduce (MPI_Op op, gfc_descriptor_t *source, int result_image, int *stat,
char *errmsg, int src_len, int errmsg_len)
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is it possible to set your editor to use spaces and not tab characters? Also, it would be great to revert the leading indentation whitespace changes, or at least fixup white space in a separate commit from when substantive edits are made.

{
size_t i, size;
int j, ierr;
int rank = GFC_DESCRIPTOR_RANK (source);

MPI_Datatype datatype = get_MPI_datatype (source);
MPI_Datatype datatype = get_MPI_datatype (source, src_len);

size = 1;
for (j = 0; j < rank; j++)
Expand All @@ -3285,17 +3327,17 @@ co_reduce_1 (MPI_Op op, gfc_descriptor_t *source, int result_image, int *stat,
if (rank == 0 || PREFIX (is_contiguous) (source))
{
if (result_image == 0)
ierr = MPI_Allreduce (MPI_IN_PLACE, source->base_addr, size, datatype,
ierr = MPI_Allreduce (MPI_IN_PLACE, source->base_addr, size, datatype,
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

please revert whitespace only changes by amending the commit if you know how... if not, I'll do it.

op, CAF_COMM_WORLD);
else if (result_image == caf_this_image)
ierr = MPI_Reduce (MPI_IN_PLACE, source->base_addr, size, datatype, op,
ierr = MPI_Reduce (MPI_IN_PLACE, source->base_addr, size, datatype, op,
result_image-1, CAF_COMM_WORLD);
else
ierr = MPI_Reduce (source->base_addr, NULL, size, datatype, op,
ierr = MPI_Reduce (source->base_addr, NULL, size, datatype, op,
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Same for these two diffs, whitespace only changes...

result_image-1, CAF_COMM_WORLD);
if (ierr)
goto error;
return;
goto co_reduce_cleanup;
}

for (i = 0; i < size; i++)
Expand All @@ -3316,18 +3358,21 @@ co_reduce_1 (MPI_Op op, gfc_descriptor_t *source, int result_image, int *stat,
void *sr = (void *)((char *) source->base_addr
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (source));
if (result_image == 0)
ierr = MPI_Allreduce (MPI_IN_PLACE, sr, 1, datatype, op,
ierr = MPI_Allreduce (MPI_IN_PLACE, sr, 1, datatype, op,
CAF_COMM_WORLD);
else if (result_image == caf_this_image)
ierr = MPI_Reduce (MPI_IN_PLACE, sr, 1, datatype, op,
ierr = MPI_Reduce (MPI_IN_PLACE, sr, 1, datatype, op,
result_image-1, CAF_COMM_WORLD);
else
ierr = MPI_Reduce (sr, NULL, 1, datatype, op, result_image-1,
ierr = MPI_Reduce (sr, NULL, 1, datatype, op, result_image-1,
CAF_COMM_WORLD);
if (ierr)
goto error;
}

co_reduce_cleanup:
if (GFC_DESCRIPTOR_TYPE (source) == BT_CHARACTER)
MPI_Type_free (&datatype);
if (stat)
*stat = 0;
return;
Expand Down Expand Up @@ -3360,7 +3405,7 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e
int j, ierr;
int rank = GFC_DESCRIPTOR_RANK (a);

MPI_Datatype datatype = get_MPI_datatype (a);
MPI_Datatype datatype = get_MPI_datatype (a, 0);

size = 1;
for (j = 0; j < rank; j++)
Expand All @@ -3375,7 +3420,7 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e
if (rank == 0)
{
if (datatype != MPI_CHARACTER)
ierr = MPI_Bcast(a->base_addr, size, datatype, source_image-1, CAF_COMM_WORLD);
ierr = MPI_Bcast(a->base_addr, size, datatype, source_image-1, CAF_COMM_WORLD);
else
{
int a_length;
Expand All @@ -3386,7 +3431,7 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e
if (ierr)
goto error;
/* Broadcast the string itself */
ierr = MPI_Bcast(a->base_addr, a_length, datatype, source_image-1, CAF_COMM_WORLD);
ierr = MPI_Bcast(a->base_addr, a_length, datatype, source_image-1, CAF_COMM_WORLD);
}

if (ierr)
Expand Down Expand Up @@ -3445,63 +3490,99 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e
memset (&errmsg[len], '\0', errmsg_len - len);
}

/** The front-end function for co_reduce functionality. It sets up the MPI_Op
* for use in MPI_*Reduce functions. */
void
PREFIX (co_reduce) (gfc_descriptor_t *a, void *(*opr) (void *, void *), int opr_flags,
int result_image, int *stat, char *errmsg, int a_len, int errmsg_len)
{
MPI_Op op;
if(GFC_DESCRIPTOR_TYPE(a) == BT_INTEGER)
/* Integers and logicals can be treated the same. */
if(GFC_DESCRIPTOR_TYPE(a) == BT_INTEGER
|| GFC_DESCRIPTOR_TYPE(a) == BT_LOGICAL)
{
foo_int32_t = (typeof(foo_int32_t))opr;
MPI_Op_create(redux_int32, 1, &op);
/* When the ARG_VALUE opr_flag is set, then the user-function expects its
* arguments to be passed by value. */
if ((opr_flags & GFC_CAF_ARG_VALUE) > 0)
{
int32_t_by_value = (typeof (VALUE_FUNC(int32_t)))opr;
MPI_Op_create(redux_int32_by_value_adapter, 1, &op);
}
else
{
int32_t_by_reference = (typeof (REFERENCE_FUNC(int32_t)))opr;
MPI_Op_create(redux_int32_by_reference_adapter, 1, &op);
}
}
/* Treat reals/doubles. */
else if(GFC_DESCRIPTOR_TYPE(a) == BT_REAL)
{
/* When the ARG_VALUE opr_flag is set, then the user-function expects its
* arguments to be passed by value. */
if(GFC_DESCRIPTOR_SIZE(a) == sizeof(float))
{
foo_float = (typeof(foo_float))opr;
MPI_Op_create(redux_real32, 1, &op);
if ((opr_flags & GFC_CAF_ARG_VALUE) > 0)
{
float_by_value = (typeof (VALUE_FUNC(float)))opr;
MPI_Op_create(redux_real32_by_value_adapter, 1, &op);
}
else
{
float_by_reference = (typeof (REFERENCE_FUNC(float)))opr;
MPI_Op_create(redux_real32_by_reference_adapter, 1, &op);
}
}
else
{
foo_double = (typeof(foo_double))opr;
MPI_Op_create(redux_real64, 1, &op);
{
/* When the ARG_VALUE opr_flag is set, then the user-function expects its
* arguments to be passed by value. */
if ((opr_flags & GFC_CAF_ARG_VALUE) > 0)
{
double_by_value = (typeof (VALUE_FUNC(double)))opr;
MPI_Op_create(redux_real64_by_value_adapter, 1, &op);
}
else
{
double_by_reference = (typeof (REFERENCE_FUNC(double)))opr;
MPI_Op_create(redux_real64_by_reference_adapter, 1, &op);
}
}
}
else if(GFC_DESCRIPTOR_TYPE(a) == BT_LOGICAL)
else if (GFC_DESCRIPTOR_TYPE(a) == BT_CHARACTER)
{
foo_int32_t = (typeof(foo_int32_t))opr;
MPI_Op_create(redux_int32, 1, &op);
/* Char array functions always pass by reference. */
char_by_reference = (typeof (REFERENCE_FUNC(char)))opr;
MPI_Op_create(redux_char_by_reference_adapter, 1, &op);
}
else
{
caf_runtime_error ("Data type not yet supported for co_reduce\n");
}

co_reduce_1 (op, a, result_image, stat, errmsg, 0, errmsg_len);
internal_co_reduce (op, a, result_image, stat, errmsg, a_len, errmsg_len);
}

void
PREFIX (co_sum) (gfc_descriptor_t *a, int result_image, int *stat, char *errmsg,
int errmsg_len)
{
co_reduce_1 (MPI_SUM, a, result_image, stat, errmsg, 0, errmsg_len);
internal_co_reduce (MPI_SUM, a, result_image, stat, errmsg, 0, errmsg_len);
}


void
PREFIX (co_min) (gfc_descriptor_t *a, int result_image, int *stat, char *errmsg,
int src_len, int errmsg_len)
{
co_reduce_1 (MPI_MIN, a, result_image, stat, errmsg, src_len, errmsg_len);
internal_co_reduce (MPI_MIN, a, result_image, stat, errmsg, src_len, errmsg_len);
}


void
PREFIX (co_max) (gfc_descriptor_t *a, int result_image, int *stat,
char *errmsg, int src_len, int errmsg_len)
{
co_reduce_1 (MPI_MAX, a, result_image, stat, errmsg, src_len, errmsg_len);
internal_co_reduce (MPI_MAX, a, result_image, stat, errmsg, src_len, errmsg_len);
}


Expand Down
6 changes: 6 additions & 0 deletions src/tests/regression/reported/CMakeLists.txt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,12 @@
add_executable(co_reduce-factorial issue-172-wrong-co_reduce.f90)
target_link_libraries(co_reduce-factorial OpenCoarrays)

add_executable(co_reduce-factorial-int8 issue-172-wrong-co_reduce-int8.f90)
target_link_libraries(co_reduce-factorial-int8 OpenCoarrays)

add_executable(co_reduce-factorial-int64 issue-172-wrong-co_reduce-int64.f90)
target_link_libraries(co_reduce-factorial-int64 OpenCoarrays)

add_executable(source-alloc-sync issue-243-source-allocation-no-sync.f90)
target_link_libraries(source-alloc-sync OpenCoarrays)

Expand Down
Loading