Skip to content

Commit 7edfd74

Browse files
vehrevehre
committed
[Issue-422] Add basic support for send_by_ref to self. (still WIP, because
compiler support is sufficient/buggy).
1 parent 9068044 commit 7edfd74

File tree

2 files changed

+90
-79
lines changed

2 files changed

+90
-79
lines changed

‎src/mpi/mpi_caf.c

Lines changed: 84 additions & 73 deletions
Original file line numberDiff line numberDiff line change
@@ -5333,20 +5333,20 @@ PREFIX (send_by_ref) (caf_token_t token, int image_index,
53335333
"rank out of range.\n";
53345334
const char extentoutofrange[] = "libcaf_mpi::caf_send_by_ref(): "
53355335
"extent out of range.\n";
5336+
const char cannotallocdst[] = "libcaf_mpi::caf_get_by_ref(): "
5337+
"can not allocate %d bytes of memory.\n";
53365338
const char unabletoallocdst[] = "libcaf_mpi::caf_send_by_ref(): "
53375339
"unable to allocate memory on remote image.\n";
53385340
const char nonallocextentmismatch[] = "libcaf_mpi::caf_send_by_ref(): "
53395341
"extent of non-allocatable arrays mismatch (%lu != %lu).\n";
5340-
const char doublearrayref[] = "libcaf_mpi::caf_get_by_ref(): "
5341-
"two or more array part references are not supported.\n";
53425342
size_t size, i, ref_rank;
53435343
size_t src_index;
53445344
int dst_rank = -1;
53455345
int src_cur_dim = 0;
53465346
size_t dst_size;
53475347
mpi_caf_token_t *mpi_token = (mpi_caf_token_t *) token;
53485348
void *remote_memptr = mpi_token->memptr, *remote_base_memptr = NULL;
5349-
gfc_max_dim_descriptor_t dst_desc;
5349+
gfc_max_dim_descriptor_t dst_desc, temp_src;
53505350
gfc_descriptor_t *dst = (gfc_descriptor_t *)&dst_desc;
53515351
caf_reference_t *riter = refs;
53525352
long delta;
@@ -5364,6 +5364,7 @@ PREFIX (send_by_ref) (caf_token_t token, int image_index,
53645364
bool access_data_through_global_win = false;
53655365
/* Set when the remote descriptor is to accessed through the global window. */
53665366
bool access_desc_through_global_win = false;
5367+
bool free_temp_src = false;
53675368

53685369
if (stat)
53695370
*stat = 0;
@@ -5556,41 +5557,41 @@ PREFIX (send_by_ref) (caf_token_t token, int image_index,
55565557
return;
55575558
}
55585559
/* Do further checks, when the source is not scalar. */
5559-
// else if (delta != 1)
5560-
// {
5561-
// /* When the realloc is required, then no extent may have
5562-
// been set. */
5563-
// extent_mismatch = GFC_DESCRIPTOR_EXTENT (dst,
5564-
// src_cur_dim)
5565-
// != delta;
5566-
// /* When it already known, that a realloc is needed or
5567-
// the extent does not match the needed one. */
5568-
// if (realloc_dst || extent_mismatch)
5569-
// {
5570-
// /* Check whether dst is reallocatable. */
5571-
// if (unlikely (!dst_reallocatable))
5572-
// {
5573-
// caf_runtime_error (nonallocextentmismatch, stat,
5574-
// NULL, 0, delta,
5575-
// GFC_DESCRIPTOR_EXTENT (dst,
5576-
// src_cur_dim));
5577-
// return;
5578-
// }
5579-
// /* Only report an error, when the extent needs to be
5580-
// modified, which is not allowed. */
5581-
// else if (!dst_reallocatable && extent_mismatch)
5582-
// {
5583-
// caf_runtime_error (extentoutofrange, stat, NULL,
5584-
// 0);
5585-
// return;
5586-
// }
5587-
// dprint ("%d/%d: %s() extent(dst): %d != delta: %d.\n",
5588-
// caf_this_image, caf_num_images, __FUNCTION__,
5589-
// GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim),
5590-
// delta);
5591-
// realloc_dst = true;
5592-
// }
5593-
// }
5560+
else if (delta != 1)
5561+
{
5562+
/* When the realloc is required, then no extent may have
5563+
been set. */
5564+
extent_mismatch = GFC_DESCRIPTOR_EXTENT (dst,
5565+
src_cur_dim)
5566+
< delta;
5567+
/* When it already known, that a realloc is needed or
5568+
the extent does not match the needed one. */
5569+
if (realloc_dst || extent_mismatch)
5570+
{
5571+
/* Check whether dst is reallocatable. */
5572+
if (unlikely (!dst_reallocatable))
5573+
{
5574+
caf_runtime_error (nonallocextentmismatch, stat,
5575+
NULL, 0, delta,
5576+
GFC_DESCRIPTOR_EXTENT (dst,
5577+
src_cur_dim));
5578+
return;
5579+
}
5580+
/* Only report an error, when the extent needs to be
5581+
modified, which is not allowed. */
5582+
else if (!dst_reallocatable && extent_mismatch)
5583+
{
5584+
caf_runtime_error (extentoutofrange, stat, NULL,
5585+
0);
5586+
return;
5587+
}
5588+
dprint ("%d/%d: %s() extent(dst): %d != delta: %d.\n",
5589+
caf_this_image, caf_num_images, __FUNCTION__,
5590+
GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim),
5591+
delta);
5592+
realloc_dst = true;
5593+
}
5594+
}
55945595

55955596
/* Only increase the dim counter, when in an array ref. */
55965597
if (in_array_ref && src_cur_dim < GFC_DESCRIPTOR_RANK (src))
@@ -5683,41 +5684,21 @@ PREFIX (send_by_ref) (caf_token_t token, int image_index,
56835684
return;
56845685
}
56855686
/* Do further checks, when the source is not scalar. */
5686-
// else if (delta != 1)
5687-
// {
5688-
// /* Check that the extent is not scalar and we are not in
5689-
// an array ref for the dst side. */
5690-
// if (!in_array_ref)
5691-
// {
5692-
// /* Check that this is the non-scalar extent. */
5693-
// if (!array_extent_fixed)
5694-
// {
5695-
// /* In an array extent now. */
5696-
// in_array_ref = true;
5697-
// /* The dst is not reallocatable, so nothing more
5698-
// to do, then correct the dim counter. */
5699-
// src_cur_dim = i;
5700-
// }
5701-
// else
5702-
// {
5703-
// caf_runtime_error (doublearrayref, stat, NULL,
5704-
// 0);
5705-
// return;
5706-
// }
5707-
// }
5708-
// /* When the realloc is required, then no extent may have
5709-
// been set. */
5710-
// extent_mismatch = GFC_DESCRIPTOR_EXTENT (dst,
5711-
// src_cur_dim)
5712-
// != delta;
5713-
// /* When it is already known, that a realloc is needed or
5714-
// the extent does not match the needed one. */
5715-
// if (realloc_dst || extent_mismatch)
5716-
// {
5717-
// caf_runtime_error(unabletoallocdst, stat);
5718-
// return;
5719-
// }
5720-
// }
5687+
else if (delta != 1)
5688+
{
5689+
/* When the realloc is required, then no extent may have
5690+
been set. */
5691+
extent_mismatch = GFC_DESCRIPTOR_EXTENT (dst,
5692+
src_cur_dim)
5693+
< delta;
5694+
/* When it is already known, that a realloc is needed or
5695+
the extent does not match the needed one. */
5696+
if (realloc_dst || extent_mismatch)
5697+
{
5698+
caf_runtime_error(unabletoallocdst, stat);
5699+
return;
5700+
}
5701+
}
57215702
/* Only increase the dim counter, when in an array ref. */
57225703
if (in_array_ref && src_cur_dim < GFC_DESCRIPTOR_RANK (src))
57235704
++src_cur_dim;
@@ -5761,12 +5742,42 @@ PREFIX (send_by_ref) (caf_token_t token, int image_index,
57615742
fprintf (stderr, "%d/%d: %s() dst_dim[%d] = (%d, %d)\n", caf_this_image, caf_num_images,
57625743
__FUNCTION__, i, src->dim[i].lower_bound, src->dim[i]._ubound);
57635744
#endif
5745+
/* When accessing myself and may_require_tmp is set, then copy the source
5746+
* array. */
5747+
if (caf_this_image == image_index && may_require_tmp)
5748+
{
5749+
dprint ("%d/%d: %s() preparing temporary source.\n", caf_this_image,
5750+
caf_num_images, __FUNCTION__);
5751+
memcpy (&temp_src, src, sizeof_desc_for_rank (GFC_DESCRIPTOR_RANK (src)));
5752+
size_t cap = 0;
5753+
for (int r = 0; r < GFC_DESCRIPTOR_RANK (src); ++r)
5754+
cap += GFC_DESCRIPTOR_EXTENT (src, r);
5755+
5756+
cap *= GFC_DESCRIPTOR_SIZE (src);
5757+
temp_src.base.base_addr = alloca (cap);
5758+
if ((free_temp_src = (temp_src.base.base_addr == NULL)))
5759+
{
5760+
temp_src.base.base_addr = malloc (cap);
5761+
if (temp_src.base.base_addr == NULL)
5762+
{
5763+
caf_runtime_error (cannotallocdst, stat, NULL, cap);
5764+
return;
5765+
}
5766+
}
5767+
memcpy (temp_src.base.base_addr, src->base_addr, cap);
5768+
src = (gfc_descriptor_t *)&temp_src;
5769+
}
5770+
57645771
i = 0;
57655772
dprint ("%d/%d: %s() calling send_for_ref.\n", caf_this_image,
57665773
caf_num_images, __FUNCTION__);
57675774
send_by_ref (refs, &i, src_index, mpi_token, mpi_token->desc, src,
57685775
remote_memptr, src->base_addr, 0, 0, dst_kind, src_kind, 0, 0,
57695776
1, stat, remote_image, false, false);
5777+
if (free_temp_src)
5778+
{
5779+
free (temp_src.base.base_addr);
5780+
}
57705781
CAF_Win_unlock (remote_image, global_dynamic_win);
57715782
CAF_Win_unlock (remote_image, mpi_token->memptr_win);
57725783
}

‎src/tests/unit/send-get/alloc_comp_send_convert_nums.f90

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -358,12 +358,12 @@ program alloc_comp_send_convert_nums
358358
if (any(obj%int_k1 /= [INT(-2, 1), int_k1(4), INT(-2, 1), int_k1(5), INT(-2, 1)])) &
359359
& error stop 'send strided int kind=4 to kind=1 self failed.'
360360

361-
! obj%int_k1(1:5) = int_k1(5:1:-1)
362-
! obj[1]%int_k1(::2) = obj%int_k1(3:1:-1)
363-
! print *, obj%int_k1
364-
! ! Note, indezes two times reversed!
365-
! if (any(obj%int_k1 /= [int_k1(3), int_k1(4), int_k1(4), int_k1(2), int_k1(5)])) &
366-
! & error stop 'send strided with temp int kind=1 to kind=1 self failed.'
361+
obj%int_k1(1:5) = int_k1(5:1:-1)
362+
obj[1]%int_k1(::2) = obj%int_k1(3:1:-1)
363+
print *, obj%int_k1
364+
! Note, indezes two times reversed!
365+
if (any(obj%int_k1 /= [int_k1(3), int_k1(4), int_k1(4), int_k1(2), int_k1(5)])) &
366+
& error stop 'send strided with temp int kind=1 to kind=1 self failed.'
367367

368368
! obj%int_k4(1:5) = int_k4(5:1:-1)
369369
! obj[1]%int_k4(::2) = obj%int_k4(3:1:-1)

0 commit comments

Comments
 (0)