Skip to content

Commit 7010d60

Browse files
vehrevehre
committed
Correct/Improve handling of runtime errors.
1 parent b57626d commit 7010d60

File tree

1 file changed

+59
-30
lines changed

1 file changed

+59
-30
lines changed

‎src/mpi/mpi_caf.c‎

Lines changed: 59 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -429,6 +429,35 @@ caf_runtime_error (const char *message, ...)
429429
exit(EXIT_FAILURE);
430430
}
431431

432+
/* Error handling is similar everytime. Keep in sync with single.c, too. */
433+
static void
434+
caf_internal_error (const char *msg, int *stat, char *errmsg,
435+
size_t errmsg_len, ...)
436+
{
437+
va_list args;
438+
va_start (args, errmsg_len);
439+
if (stat)
440+
{
441+
*stat = 1;
442+
if (errmsg_len > 0)
443+
{
444+
int len = snprintf (errmsg, errmsg_len, msg, args);
445+
if (len >= 0 && errmsg_len > (size_t) len)
446+
memset (&errmsg[len], ' ', errmsg_len - len);
447+
}
448+
va_end (args);
449+
return;
450+
}
451+
else
452+
{
453+
fprintf(stderr, "Fortran runtime error on image %d: ", caf_this_image);
454+
vfprintf(stderr, msg, args);
455+
fprintf(stderr, "\n");
456+
}
457+
va_end (args);
458+
exit(EXIT_FAILURE);
459+
}
460+
432461
/* Forward declaration of the feature unsupported message for failed images
433462
* functions. */
434463
static void
@@ -4705,7 +4734,7 @@ case kind: \
47054734
KINDCASE(16, __int128);
47064735
#endif
47074736
default:
4708-
caf_runtime_error(vecrefunknownkind, stat, NULL, 0);
4737+
caf_internal_error(vecrefunknownkind, stat, NULL, 0);
47094738
return;
47104739
}
47114740
#undef KINDCASE
@@ -4751,7 +4780,7 @@ case kind: \
47514780
* in a dimension. */
47524781
break;
47534782
default:
4754-
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
4783+
caf_internal_error(unknownarrreftype, stat, NULL, 0);
47554784
return;
47564785
}
47574786
dprint("i = %zd, array_ref = %s, delta = %ld\n", i,
@@ -4763,7 +4792,7 @@ case kind: \
47634792
if (delta > 1 && dst_rank == 0)
47644793
{
47654794
/* No, an array is required, but not provided. */
4766-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
4795+
caf_internal_error(extentoutofrange, stat, NULL, 0);
47674796
return;
47684797
}
47694798
/* When dst is an array. */
@@ -4773,7 +4802,7 @@ case kind: \
47734802
* only by scalar data. */
47744803
if (dst_cur_dim >= dst_rank && delta != 1)
47754804
{
4776-
caf_runtime_error(rankoutofrange, stat, NULL, 0);
4805+
caf_internal_error(rankoutofrange, stat, NULL, 0);
47774806
return;
47784807
}
47794808
/* Do further checks, when the source is not scalar. */
@@ -4811,7 +4840,7 @@ case kind: \
48114840
}
48124841
else
48134842
{
4814-
caf_runtime_error(doublearrayref, stat, NULL, 0);
4843+
caf_internal_error(doublearrayref, stat, NULL, 0);
48154844
return;
48164845
}
48174846
}
@@ -4826,7 +4855,7 @@ case kind: \
48264855
/* Check whether dst is reallocatable. */
48274856
if (unlikely(!dst_reallocatable))
48284857
{
4829-
caf_runtime_error(nonallocextentmismatch, stat,
4858+
caf_internal_error(nonallocextentmismatch, stat,
48304859
NULL, 0, delta,
48314860
GFC_DESCRIPTOR_EXTENT(dst, dst_cur_dim));
48324861
return;
@@ -4835,7 +4864,7 @@ case kind: \
48354864
* which is not allowed. */
48364865
else if (!dst_reallocatable && extent_mismatch)
48374866
{
4838-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
4867+
caf_internal_error(extentoutofrange, stat, NULL, 0);
48394868
return;
48404869
}
48414870
realloc_needed = true;
@@ -4893,7 +4922,7 @@ case kind: \
48934922
KINDCASE(16, __int128);
48944923
#endif
48954924
default:
4896-
caf_runtime_error(vecrefunknownkind, stat, NULL, 0);
4925+
caf_internal_error(vecrefunknownkind, stat, NULL, 0);
48974926
return;
48984927
}
48994928
#undef KINDCASE
@@ -4924,7 +4953,7 @@ case kind: \
49244953
* not occur here. */
49254954
case CAF_ARR_REF_OPEN_START:
49264955
default:
4927-
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
4956+
caf_internal_error(unknownarrreftype, stat, NULL, 0);
49284957
return;
49294958
}
49304959
dprint("i = %zd, array_ref = %s, delta = %ld\n",
@@ -4936,7 +4965,7 @@ case kind: \
49364965
if (delta > 1 && dst_rank == 0)
49374966
{
49384967
/* No, an array is required, but not provided. */
4939-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
4968+
caf_internal_error(extentoutofrange, stat, NULL, 0);
49404969
return;
49414970
}
49424971
/* When dst is an array. */
@@ -4946,7 +4975,7 @@ case kind: \
49464975
* only by scalar data. */
49474976
if (dst_cur_dim >= dst_rank && delta != 1)
49484977
{
4949-
caf_runtime_error(rankoutofrange, stat, NULL, 0);
4978+
caf_internal_error(rankoutofrange, stat, NULL, 0);
49504979
return;
49514980
}
49524981
/* Do further checks, when the source is not scalar. */
@@ -4967,7 +4996,7 @@ case kind: \
49674996
}
49684997
else
49694998
{
4970-
caf_runtime_error(doublearrayref, stat, NULL, 0);
4999+
caf_internal_error(doublearrayref, stat, NULL, 0);
49715000
return;
49725001
}
49735002
}
@@ -4982,7 +5011,7 @@ case kind: \
49825011
/* Check whether dst is reallocatable. */
49835012
if (unlikely(!dst_reallocatable))
49845013
{
4985-
caf_runtime_error(nonallocextentmismatch, stat,
5014+
caf_internal_error(nonallocextentmismatch, stat,
49865015
NULL, 0, delta,
49875016
GFC_DESCRIPTOR_EXTENT(dst, dst_cur_dim));
49885017
return;
@@ -4991,7 +5020,7 @@ case kind: \
49915020
* which is not allowed. */
49925021
else if (!dst_reallocatable && extent_mismatch)
49935022
{
4994-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
5023+
caf_internal_error(extentoutofrange, stat, NULL, 0);
49955024
return;
49965025
}
49975026
realloc_needed = true;
@@ -5025,7 +5054,7 @@ case kind: \
50255054
}
50265055
break;
50275056
default:
5028-
caf_runtime_error(unknownreftype, stat, NULL, 0);
5057+
caf_internal_error(unknownreftype, stat, NULL, 0);
50295058
return;
50305059
}
50315060
src_size = riter->item_size;
@@ -5053,7 +5082,7 @@ case kind: \
50535082
dst->base_addr = malloc(size * GFC_DESCRIPTOR_SIZE(dst));
50545083
if (unlikely(dst->base_addr == NULL))
50555084
{
5056-
caf_runtime_error(cannotallocdst, stat, size * GFC_DESCRIPTOR_SIZE(dst));
5085+
caf_internal_error(cannotallocdst, stat, NULL, 0, size * GFC_DESCRIPTOR_SIZE(dst));
50575086
return;
50585087
}
50595088
}
@@ -5912,7 +5941,7 @@ case kind: \
59125941
KINDCASE(16, __int128);
59135942
#endif
59145943
default:
5915-
caf_runtime_error(vecrefunknownkind, stat, NULL, 0);
5944+
caf_internal_error(vecrefunknownkind, stat, NULL, 0);
59165945
return;
59175946
}
59185947
#undef KINDCASE
@@ -5958,7 +5987,7 @@ case kind: \
59585987
* a dimension. */
59595988
break;
59605989
default:
5961-
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
5990+
caf_internal_error(unknownarrreftype, stat, NULL, 0);
59625991
return;
59635992
} // switch
59645993
dprint("i = %zd, array_ref = %s, delta = %ld\n",
@@ -5972,7 +6001,7 @@ case kind: \
59726001
if (delta > 1 && dst_rank == 0)
59736002
{
59746003
/* No, an array is required, but not provided. */
5975-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
6004+
caf_internal_error(extentoutofrange, stat, NULL, 0);
59766005
return;
59776006
}
59786007
/* When dst is an array. */
@@ -5982,7 +6011,7 @@ case kind: \
59826011
* only by scalar data. */
59836012
if (src_cur_dim >= dst_rank && delta != 1)
59846013
{
5985-
caf_runtime_error(rankoutofrange, stat, NULL, 0);
6014+
caf_internal_error(rankoutofrange, stat, NULL, 0);
59866015
return;
59876016
}
59886017
/* Do further checks, when the source is not scalar. */
@@ -5999,7 +6028,7 @@ case kind: \
59996028
/* Check whether dst is reallocatable. */
60006029
if (unlikely(!dst_reallocatable))
60016030
{
6002-
caf_runtime_error(nonallocextentmismatch, stat,
6031+
caf_internal_error(nonallocextentmismatch, stat,
60036032
NULL, 0, delta,
60046033
GFC_DESCRIPTOR_EXTENT(dst, src_cur_dim));
60056034
return;
@@ -6008,7 +6037,7 @@ case kind: \
60086037
* modified, which is not allowed. */
60096038
else if (!dst_reallocatable && extent_mismatch)
60106039
{
6011-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
6040+
caf_internal_error(extentoutofrange, stat, NULL, 0);
60126041
return;
60136042
}
60146043
dprint("extent(dst, %d): %zd != delta: %ld.\n", src_cur_dim,
@@ -6048,7 +6077,7 @@ case kind: \
60486077
KINDCASE(16, __int128);
60496078
#endif
60506079
default:
6051-
caf_runtime_error(vecrefunknownkind, stat, NULL, 0);
6080+
caf_internal_error(vecrefunknownkind, stat, NULL, 0);
60526081
return;
60536082
}
60546083
#undef KINDCASE
@@ -6078,7 +6107,7 @@ case kind: \
60786107
* can not occur here. */
60796108
case CAF_ARR_REF_OPEN_START:
60806109
default:
6081-
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
6110+
caf_internal_error(unknownarrreftype, stat, NULL, 0);
60826111
return;
60836112
} // switch
60846113
dprint("i = %zd, array_ref = %s, delta = %ld\n",
@@ -6092,7 +6121,7 @@ case kind: \
60926121
if (delta > 1 && dst_rank == 0)
60936122
{
60946123
/* No, an array is required, but not provided. */
6095-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
6124+
caf_internal_error(extentoutofrange, stat, NULL, 0);
60966125
return;
60976126
}
60986127
/* When dst is an array. */
@@ -6102,7 +6131,7 @@ case kind: \
61026131
* only by scalar data. */
61036132
if (src_cur_dim >= dst_rank && delta != 1)
61046133
{
6105-
caf_runtime_error(rankoutofrange, stat, NULL, 0);
6134+
caf_internal_error(rankoutofrange, stat, NULL, 0);
61066135
return;
61076136
}
61086137
/* Do further checks, when the source is not scalar. */
@@ -6116,7 +6145,7 @@ case kind: \
61166145
* the extent does not match the needed one. */
61176146
if (realloc_dst || extent_mismatch)
61186147
{
6119-
caf_runtime_error(unabletoallocdst, stat);
6148+
caf_internal_error(unabletoallocdst, stat, NULL, 0);
61206149
return;
61216150
}
61226151
}
@@ -6128,7 +6157,7 @@ case kind: \
61286157
in_array_ref = false;
61296158
break;
61306159
default:
6131-
caf_runtime_error(unknownreftype, stat, NULL, 0);
6160+
caf_internal_error(unknownreftype, stat, NULL, 0);
61326161
return;
61336162
}
61346163
dst_size = riter->item_size;
@@ -6143,7 +6172,7 @@ case kind: \
61436172

61446173
if (realloc_dst)
61456174
{
6146-
caf_runtime_error(unabletoallocdst, stat);
6175+
caf_internal_error(unabletoallocdst, stat, NULL, 0);
61476176
return;
61486177
}
61496178

@@ -6178,7 +6207,7 @@ case kind: \
61786207
temp_src.base.base_addr = malloc(cap);
61796208
if (temp_src.base.base_addr == NULL)
61806209
{
6181-
caf_runtime_error(cannotallocdst, stat, NULL, cap);
6210+
caf_internal_error(cannotallocdst, stat, NULL, cap);
61826211
return;
61836212
}
61846213
}

0 commit comments

Comments
 (0)