PR fortran/98301 - random_init() is broken
Correct implementation of random_init() when -fcoarray=lib is given. Backport from mainline. 2021-06-06 Andre Vehreschild <vehre@gcc.gnu.org> Steve Kargl <kargl@gcc.gnu.org> gcc/fortran/ChangeLog: PR fortran/98301 * trans-decl.c (gfc_build_builtin_function_decls): Move decl. * trans-intrinsic.c (conv_intrinsic_random_init): Use bool for lib-call of caf_random_init instead of logical (4-byte). * trans.h: Add tree var for random_init. libgfortran/ChangeLog: PR fortran/98301 * caf/libcaf.h (_gfortran_caf_random_init): New function. * caf/single.c (_gfortran_caf_random_init): New function. * gfortran.map: Added fndecl. * intrinsics/random_init.f90: Implement random_init.
This commit is contained in:
Andre Vehreschild
parent
4fff5f1782
commit
002745ca36
@ -170,6 +170,7 @@ tree gfor_fndecl_co_min;
|
||||
tree gfor_fndecl_co_reduce;
|
||||
tree gfor_fndecl_co_sum;
|
||||
tree gfor_fndecl_caf_is_present;
|
||||
tree gfor_fndecl_caf_random_init;
|
||||
|
||||
|
||||
/* Math functions. Many other math functions are handled in
|
||||
@ -233,7 +234,7 @@ tree gfor_fndecl_cgemm;
|
||||
tree gfor_fndecl_zgemm;
|
||||
|
||||
/* RANDOM_INIT function. */
|
||||
tree gfor_fndecl_random_init;
|
||||
tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */
|
||||
|
||||
static void
|
||||
gfc_add_decl_to_parent_function (tree decl)
|
||||
@ -3516,6 +3517,8 @@ gfc_build_intrinsic_function_decls (void)
|
||||
void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node,
|
||||
gfc_int4_type_node);
|
||||
|
||||
// gfor_fndecl_caf_rand_init is defined in the lib-coarray section below.
|
||||
|
||||
gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
|
||||
get_identifier (PREFIX("selected_char_kind")), ". . R ",
|
||||
gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
|
||||
@ -4081,6 +4084,10 @@ gfc_build_builtin_function_decls (void)
|
||||
get_identifier (PREFIX("caf_is_present")), ". r . r ",
|
||||
integer_type_node, 3, pvoid_type_node, integer_type_node,
|
||||
pvoid_type_node);
|
||||
|
||||
gfor_fndecl_caf_random_init = gfc_build_library_function_decl (
|
||||
get_identifier (PREFIX("caf_random_init")),
|
||||
void_type_node, 2, logical_type_node, logical_type_node);
|
||||
}
|
||||
|
||||
gfc_build_intrinsic_function_decls ();
|
||||
|
||||
@ -3837,38 +3837,43 @@ conv_intrinsic_random_init (gfc_code *code)
|
||||
{
|
||||
stmtblock_t block;
|
||||
gfc_se se;
|
||||
tree arg1, arg2, arg3, tmp;
|
||||
tree logical4_type_node = gfc_get_logical_type (4);
|
||||
tree arg1, arg2, tmp;
|
||||
/* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
|
||||
tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
|
||||
? logical_type_node
|
||||
: gfc_get_logical_type (4);
|
||||
|
||||
/* Make the function call. */
|
||||
gfc_init_block (&block);
|
||||
gfc_init_se (&se, NULL);
|
||||
|
||||
/* Convert REPEATABLE to a LOGICAL(4) entity. */
|
||||
/* Convert REPEATABLE to the desired LOGICAL entity. */
|
||||
gfc_conv_expr (&se, code->ext.actual->expr);
|
||||
gfc_add_block_to_block (&block, &se.pre);
|
||||
arg1 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block));
|
||||
arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
|
||||
gfc_add_block_to_block (&block, &se.post);
|
||||
|
||||
/* Convert IMAGE_DISTINCT to a LOGICAL(4) entity. */
|
||||
/* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
|
||||
gfc_conv_expr (&se, code->ext.actual->next->expr);
|
||||
gfc_add_block_to_block (&block, &se.pre);
|
||||
arg2 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block));
|
||||
arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
|
||||
gfc_add_block_to_block (&block, &se.post);
|
||||
|
||||
/* Create the hidden argument. For non-coarray codes and -fcoarray=single,
|
||||
simply set this to 0. For -fcoarray=lib, generate a call to
|
||||
THIS_IMAGE() without arguments. */
|
||||
arg3 = build_int_cst (gfc_get_int_type (4), 0);
|
||||
if (flag_coarray == GFC_FCOARRAY_LIB)
|
||||
{
|
||||
arg3 = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image,
|
||||
1, arg3);
|
||||
se.expr = fold_convert (gfc_get_int_type (4), arg3);
|
||||
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
|
||||
2, arg1, arg2);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* The ABI for libgfortran needs to be maintained, so a hidden
|
||||
argument must be include if code is compiled with -fcoarray=single
|
||||
or without the option. Set to 0. */
|
||||
tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
|
||||
tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
|
||||
3, arg1, arg2, arg3);
|
||||
}
|
||||
|
||||
tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, 3,
|
||||
arg1, arg2, arg3);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
|
||||
return gfc_finish_block (&block);
|
||||
|
||||
@ -969,6 +969,7 @@ extern GTY(()) tree gfor_fndecl_ieee_procedure_exit;
|
||||
|
||||
/* RANDOM_INIT. */
|
||||
extern GTY(()) tree gfor_fndecl_random_init;
|
||||
extern GTY(()) tree gfor_fndecl_caf_random_init;
|
||||
|
||||
/* True if node is an integer constant. */
|
||||
#define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST)
|
||||
|
||||
@ -261,4 +261,6 @@ void _gfortran_caf_stopped_images (gfc_descriptor_t *,
|
||||
|
||||
int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *);
|
||||
|
||||
void _gfortran_caf_random_init (bool, bool);
|
||||
|
||||
#endif /* LIBCAF_H */
|
||||
|
||||
@ -3135,3 +3135,13 @@ _gfortran_caf_is_present (caf_token_t token,
|
||||
}
|
||||
return memptr != NULL;
|
||||
}
|
||||
|
||||
/* Reference the libraries implementation. */
|
||||
extern void _gfortran_random_init (int32_t, int32_t, int32_t);
|
||||
|
||||
void _gfortran_caf_random_init (bool repeatable, bool image_distinct)
|
||||
{
|
||||
/* In a single image implementation always forward to the gfortran
|
||||
routine. */
|
||||
_gfortran_random_init (repeatable, image_distinct, 1);
|
||||
}
|
||||
|
||||
@ -1629,3 +1629,8 @@ GFORTRAN_10.2 {
|
||||
_gfortran_mfindloc1_c10;
|
||||
_gfortran_sfindloc1_c10;
|
||||
} GFORTRAN_10;
|
||||
|
||||
GFORTRAN_12 {
|
||||
global:
|
||||
_gfortran_caf_random_init;
|
||||
} GFORTRAN_10.2;
|
||||
|
||||
@ -1,94 +1,100 @@
|
||||
! Copyright (C) 2018-2021 Free Software Foundation, Inc.
|
||||
! Contributed by Steven G. Kargl <kargl@gcc.gnu.org>
|
||||
!
|
||||
!
|
||||
! This file is part of the GNU Fortran runtime library (libgfortran).
|
||||
!
|
||||
!
|
||||
! Libgfortran 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 of the License, or (at your option) any later version.
|
||||
!
|
||||
!
|
||||
! Libgfortran 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
|
||||
! <http://www.gnu.org/licenses/>.
|
||||
!
|
||||
!
|
||||
! WARNING: This file should never be compiled with an option that changes
|
||||
! default logical kind from 4 to some other value or changes default integer
|
||||
! kind from from 4 to some other value.
|
||||
! kind from 4 to some other value.
|
||||
!
|
||||
! There are four combinations of repeatable and image_distinct. The
|
||||
! language below is from the F2018 standard (actually, J3/18-007r1).
|
||||
!
|
||||
! There are four combinations of repeatable and image_distinct. If a program
|
||||
! is compiled without the -fcoarray= option or with -fcoarray=single, then
|
||||
! execution of the compiled executable does not use image_distinct as it is
|
||||
! irrelevant (although required). The behavior is as follows:
|
||||
! This routine is only used for non-coarray programs or with programs
|
||||
! compiled with -fcoarray=single. Use of -fcoarray=lib or -fcoarray=shared
|
||||
! requires different routines due to the need for communication between
|
||||
! images under case(iv).
|
||||
!
|
||||
! call random_init(.true., .true.)
|
||||
! Technically, neither image_distinct nor image_num are now needed. The
|
||||
! interface to _gfortran_random_init() is maintained for libgfortran ABI.
|
||||
! Note, the Fortran standard requires the image_distinct argument, so
|
||||
! it will always have a valid value, and the frontend generates an value
|
||||
! of 0 for image_num.
|
||||
!
|
||||
! The sequence of random numbers is repeatable within an instance of program
|
||||
! execution. That is, calls to random_init(.true., .true.) during the
|
||||
! execution will reset the sequence of RN to the same sequence. If the
|
||||
! program is compiled with -fcoarray=lib and multiple images are instantiated,
|
||||
! then each image accesses a repeatable distinct sequence of random numbers.
|
||||
! There are no guarantees that multiple execution of the program will access
|
||||
! the same sequence.
|
||||
!
|
||||
! call random_init(.false., .false.)
|
||||
! call random_init(.false., .true.)
|
||||
!
|
||||
! The sequence of random numbers is determined from process-dependent seeds.
|
||||
! On each execution of the executable, different seeds will be used. For
|
||||
! -fcoarray=lib and multiple instantiated images, each image will use
|
||||
! process-dependent seeds. In other words, the two calls have identical
|
||||
! behavior.
|
||||
!
|
||||
! call random_init(.true., .false.)
|
||||
!
|
||||
! For a program compiled without the -fcoarray= option or with
|
||||
! -fcoarray=single, a single image is instantiated when the executable is
|
||||
! run. If the executable causes multiple images to be instantiated, then
|
||||
! image_distinct=.false. in one image cannot affect the sequence of random
|
||||
! numbers in another image. As gfortran gives each image its own independent
|
||||
! PRNG, this condition is automatically satisfied.
|
||||
!
|
||||
impure subroutine _gfortran_random_init(repeatable, image_distinct, hidden)
|
||||
impure subroutine _gfortran_random_init(repeatable, image_distinct, image_num)
|
||||
|
||||
implicit none
|
||||
|
||||
logical, value, intent(in) :: repeatable
|
||||
logical, value, intent(in) :: image_distinct
|
||||
integer, value, intent(in) :: hidden
|
||||
integer, value, intent(in) :: image_num
|
||||
|
||||
logical, save :: once = .true.
|
||||
integer :: nseed
|
||||
integer :: nseed, lcg_seed
|
||||
integer, save, allocatable :: seed(:)
|
||||
|
||||
if (once) then
|
||||
once = .false.
|
||||
call random_seed(size=nseed)
|
||||
allocate(seed(nseed))
|
||||
call random_seed(get=seed)
|
||||
if (repeatable) then
|
||||
if (once) then
|
||||
once = .false.
|
||||
call random_seed(size=nseed)
|
||||
allocate(seed(nseed))
|
||||
lcg_seed = 57911963
|
||||
call _gfortran_lcg(seed)
|
||||
end if
|
||||
call random_seed(put=seed)
|
||||
else
|
||||
call random_seed()
|
||||
!
|
||||
! To guarantee that seed is distinct on multiple images, add the hidden
|
||||
! argument (which is the image index).
|
||||
! This cannot happen; but, prevent gfortran complaining about
|
||||
! unused variables.
|
||||
!
|
||||
if (image_distinct) seed = seed + hidden
|
||||
if (image_num > 2) then
|
||||
block
|
||||
use iso_fortran_env, only : error_unit
|
||||
write(error_unit, '(A)') 'whoops: random_init(.false., .false.)'
|
||||
if (image_distinct) error stop image_num + 1
|
||||
error stop image_num
|
||||
end block
|
||||
end if
|
||||
end if
|
||||
|
||||
if (repeatable) then
|
||||
call random_seed(put=seed);
|
||||
else
|
||||
call random_seed();
|
||||
end if
|
||||
contains
|
||||
!
|
||||
! SK Park and KW Miller, ``Random number generators: good ones are hard
|
||||
! to find,'' Comm. ACM, 31(10), 1192--1201, (1988).
|
||||
!
|
||||
! Implementation of a prime modulus multiplicative linear congruential
|
||||
! generator, which avoids overflow and provides the full period.
|
||||
!
|
||||
impure elemental subroutine _gfortran_lcg(i)
|
||||
implicit none
|
||||
integer, intent(out) :: i
|
||||
integer, parameter :: a = 16807 ! Multiplier
|
||||
integer, parameter :: m = huge(a) ! Modulus
|
||||
integer, parameter :: q = 127773 ! Quotient to avoid overflow
|
||||
integer, parameter :: r = 2836 ! Remainder to avoid overflow
|
||||
lcg_seed = a * mod(lcg_seed, q) - r * (lcg_seed / q)
|
||||
if (lcg_seed <= 0) lcg_seed = lcg_seed + m
|
||||
i = lcg_seed
|
||||
end subroutine _gfortran_lcg
|
||||
|
||||
end subroutine _gfortran_random_init
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user