Skip to content

R
riscv-gcc-1
Commit b5116268 by Tobias Burnus Committed by Tobias Burnus
Options

check.c (gfc_check_atomic, [...]): Use argument for GFC_ISYM_CAF_GET. 

gcc/fortran/
2014-06-17  Tobias Burnus  <burnus@net-b.de>

        * check.c (gfc_check_atomic, gfc_check_atomic_def):
        Use argument for GFC_ISYM_CAF_GET.
        * resolve.c (resolve_variable): Enable CAF_GET insertion.
        (resolve_lock_unlock): Remove GFC_ISYM_CAF_GET.
        (resolve_ordinary_assign): Enable CAF_SEND insertion.
        * trans-const.c (gfc_build_string_const,
        gfc_build_wide_string_const): Set TYPE_STRING_FLAG.
        * trans-decl.c (gfor_fndecl_caf_get, gfor_fndecl_caf_send,
        gfor_fndecl_caf_sendget): New global variables.
        (gfc_build_builtin_function_decls): Initialize them;
        update co_min/max/sum initialization.
        * trans-expr.c (gfc_get_tree_for_caf_expr): Renamed from
        get_tree_for_caf_expr and removed static.
        (gfc_conv_procedure_call): Update call.
        * trans-intrinsic.c (caf_get_image_index,
        conv_caf_vector_subscript_elem, conv_caf_vector_subscript,
        get_caf_token_offset, gfc_conv_intrinsic_caf_get,
        conv_caf_send): New.
        (gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine,
        gfc_walk_intrinsic_function): Handle CAF_GET and CAF_SEND.
        (conv_co_minmaxsum): Update call for remove unused vector
        subscript.
        (conv_intrinsic_atomic_def, conv_intrinsic_atomic_ref):
        Skip a CAF_GET of the argument.
        * trans-types.c (gfc_get_caf_vector_type): New.
        * trans-types.h (gfc_get_caf_vector_type): New.
        * trans.h (gfor_fndecl_caf_get, gfor_fndecl_caf_send,
        gfor_fndecl_caf_sendget): New global variables.
        (gfc_get_tree_for_caf_expr): New prototypes.

libgfortran/
2014-06-17  Tobias Burnus  <burnus@net-b.de>

        * caf/libcaf.h (gfc_descriptor_t): New typedef.
        (caf_vector_t): Update.
        (_gfortran_caf_co_sum, _gfortran_caf_co_max, _gfortran_caf_co_min):
        Remove vector-subscript argument.
        (_gfortran_caf_co_send, _gfortran_caf_co_get,
        _gfortran_caf_co_sendget): New.
        * caf/single.c (_gfortran_caf_co_sum, _gfortran_caf_co_max,
        _gfortran_caf_co_min): Remove vector-subscript argument.
        (_gfortran_caf_co_send, _gfortran_caf_co_get,
        _gfortran_caf_co_sendget): New.

gcc/testsuite/
2014-06-17  Tobias Burnus  <burnus@net-b.de>
            Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>

        * gfortran.dg/coarray/send_array.f90: New.
        * gfortran.dg/coarray/get_array.f90: New.
        * gfortran.dg/coarray/sendget_array.f90: New.
        * gfortran.dg/coarray/collectives_1.f90: Correct subroutine
        names.
        * gfortran.dg/coarray/collectives_2.f90: New.



Co-Authored-By: Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>

From-SVN: r211748
parent dc3368d0
Showing with 1094 additions and 31 deletions
gcc/fortran/ChangeLog
2014-06-17 Tobias Burnus <burnus@net-b.de>
* check.c (gfc_check_atomic, gfc_check_atomic_def):
Use argument for GFC_ISYM_CAF_GET.
* resolve.c (resolve_variable): Enable CAF_GET insertion.
(resolve_lock_unlock): Remove GFC_ISYM_CAF_GET.
(resolve_ordinary_assign): Enable CAF_SEND insertion.
* trans-const.c (gfc_build_string_const,
gfc_build_wide_string_const): Set TYPE_STRING_FLAG.
* trans-decl.c (gfor_fndecl_caf_get, gfor_fndecl_caf_send,
gfor_fndecl_caf_sendget): New global variables.
(gfc_build_builtin_function_decls): Initialize them;
update co_min/max/sum initialization.
* trans-expr.c (gfc_get_tree_for_caf_expr): Renamed from
get_tree_for_caf_expr and removed static.
(gfc_conv_procedure_call): Update call.
* trans-intrinsic.c (caf_get_image_index,
conv_caf_vector_subscript_elem, conv_caf_vector_subscript,
get_caf_token_offset, gfc_conv_intrinsic_caf_get,
conv_caf_send): New.
(gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine,
gfc_walk_intrinsic_function): Handle CAF_GET and CAF_SEND.
(conv_co_minmaxsum): Update call for remove unused vector
subscript.
(conv_intrinsic_atomic_def, conv_intrinsic_atomic_ref):
Skip a CAF_GET of the argument.
* trans-types.c (gfc_get_caf_vector_type): New.
* trans-types.h (gfc_get_caf_vector_type): New.
* trans.h (gfor_fndecl_caf_get, gfor_fndecl_caf_send,
gfor_fndecl_caf_sendget): New global variables.
(gfc_get_tree_for_caf_expr): New prototypes.
2014-06-15 Jan Hubicka <hubicka@ucw.cz>
* trans-common.c (build_common_decl): Use
......
gcc/fortran/check.c
......@@ -1008,6 +1008,11 @@ gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
static bool
gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
{
if (atom->expr_type == EXPR_FUNCTION
&& atom->value.function.isym
&& atom->value.function.isym->id == GFC_ISYM_CAF_GET)
atom = atom->value.function.actual->expr;
if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
&& !(atom->ts.type == BT_LOGICAL
&& atom->ts.kind == gfc_atomic_logical_kind))
......@@ -1040,6 +1045,11 @@ gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
bool
gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
{
if (atom->expr_type == EXPR_FUNCTION
&& atom->value.function.isym
&& atom->value.function.isym->id == GFC_ISYM_CAF_GET)
atom = atom->value.function.actual->expr;
if (!scalar_check (atom, 0) || !scalar_check (value, 1))
return false;
......
gcc/fortran/resolve.c
......@@ -4766,7 +4766,7 @@ remove_caf_get_intrinsic (gfc_expr *e)
gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
&& e->value.function.isym->id == GFC_ISYM_CAF_GET);
gfc_expr *e2 = e->value.function.actual->expr;
e->value.function.actual->expr =NULL;
e->value.function.actual->expr = NULL;
gfc_free_actual_arglist (e->value.function.actual);
gfc_free_shape (&e->shape, e->rank);
*e = *e2;
......@@ -5056,7 +5056,7 @@ resolve_procedure:
if (t)
expression_rank (e);
if (0 && t && gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
if (t && gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
add_caf_get_intrinsic (e);
return t;
......@@ -8424,6 +8424,11 @@ find_reachable_labels (gfc_code *block)
static void
resolve_lock_unlock (gfc_code *code)
{
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr1);
if (code->expr1->ts.type != BT_DERIVED
|| code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
......@@ -9276,8 +9281,22 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
gfc_check_assign (lhs, rhs, 1);
if (0 && lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB)
{
/* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
Additionally, insert this code when the RHS is a CAF as we then use the
GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
the LHS is (re)allocatable or has a vector subscript. */
if (gfc_option.coarray == GFC_FCOARRAY_LIB
&& (lhs_coindexed
|| (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
&& !gfc_expr_attr (rhs).allocatable
&& !gfc_has_vector_subscript (rhs))))
{
if (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr2);
code->op = EXEC_CALL;
gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
code->resolved_sym = code->symtree->n.sym;
......@@ -9919,6 +9938,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (!t)
break;
/* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
the LHS. */
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
......
gcc/fortran/trans-const.c
......@@ -81,6 +81,7 @@ gfc_build_string_const (int length, const char *s)
build_array_type (gfc_character1_type_node,
build_range_type (gfc_charlen_type_node,
size_one_node, len));
TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
return str;
}
......@@ -110,6 +111,7 @@ gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
build_array_type (gfc_get_char_type (kind),
build_range_type (gfc_charlen_type_node,
size_one_node, len));
TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
return str;
}
......
gcc/fortran/trans-decl.c
......@@ -127,6 +127,9 @@ tree gfor_fndecl_caf_this_image;
tree gfor_fndecl_caf_num_images;
tree gfor_fndecl_caf_register;
tree gfor_fndecl_caf_deregister;
tree gfor_fndecl_caf_get;
tree gfor_fndecl_caf_send;
tree gfor_fndecl_caf_sendget;
tree gfor_fndecl_caf_critical;
tree gfor_fndecl_caf_end_critical;
tree gfor_fndecl_caf_sync_all;
......@@ -3327,6 +3330,22 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 8,
pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 8,
pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node,
12, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
pvoid_type_node, pvoid_type_node, size_type_node, integer_type_node,
pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
gfor_fndecl_caf_critical = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_critical")), void_type_node, 0);
......@@ -3355,18 +3374,18 @@ gfc_build_builtin_function_decls (void)
TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_max")), "WR.WW",
void_type_node, 7, pvoid_type_node, pvoid_type_node, integer_type_node,
get_identifier (PREFIX("caf_co_max")), "W.WW",
void_type_node, 6, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node, integer_type_node);
gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_min")), "WR.WW",
void_type_node, 7, pvoid_type_node, pvoid_type_node, integer_type_node,
get_identifier (PREFIX("caf_co_min")), "W.WW",
void_type_node, 6, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node, integer_type_node);
gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_sum")), "WR.WW",
void_type_node, 6, pvoid_type_node, pvoid_type_node, integer_type_node,
get_identifier (PREFIX("caf_co_sum")), "W.WW",
void_type_node, 5, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
}
......
gcc/fortran/trans-expr.c
......@@ -1384,8 +1384,8 @@ gfc_get_expr_charlen (gfc_expr *e)
/* Return for an expression the backend decl of the coarray. */
static tree
get_tree_for_caf_expr (gfc_expr *expr)
tree
gfc_get_tree_for_caf_expr (gfc_expr *expr)
{
tree caf_decl;
bool found;
......@@ -4807,7 +4807,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tree caf_decl, caf_type;
tree offset, tmp2;
caf_decl = get_tree_for_caf_expr (e);
caf_decl = gfc_get_tree_for_caf_expr (e);
caf_type = TREE_TYPE (caf_decl);
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
......
gcc/fortran/trans-types.c
......@@ -3107,4 +3107,91 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
return true;
}
/* Create a type to handle vector subscripts for coarray library calls. It
has the form:
struct caf_vector_t {
size_t nvec; // size of the vector
union {
struct {
void *vector;
int kind;
} v;
struct {
ptrdiff_t lower_bound;
ptrdiff_t upper_bound;
ptrdiff_t stride;
} triplet;
} u;
}
where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
tree
gfc_get_caf_vector_type (int dim)
{
static tree vector_types[GFC_MAX_DIMENSIONS];
static tree vec_type = NULL_TREE;
tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
if (vector_types[dim-1] != NULL_TREE)
return vector_types[dim-1];
if (vec_type == NULL_TREE)
{
chain = 0;
vect_struct_type = make_node (RECORD_TYPE);
tmp = gfc_add_field_to_struct_1 (vect_struct_type,
get_identifier ("vector"),
pvoid_type_node, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (vect_struct_type,
get_identifier ("kind"),
integer_type_node, &chain);
TREE_NO_WARNING (tmp) = 1;
gfc_finish_type (vect_struct_type);
chain = 0;
triplet_struct_type = make_node (RECORD_TYPE);
tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
get_identifier ("lower_bound"),
gfc_array_index_type, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
get_identifier ("upper_bound"),
gfc_array_index_type, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
gfc_array_index_type, &chain);
TREE_NO_WARNING (tmp) = 1;
gfc_finish_type (triplet_struct_type);
chain = 0;
union_type = make_node (UNION_TYPE);
tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
vect_struct_type, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
triplet_struct_type, &chain);
TREE_NO_WARNING (tmp) = 1;
gfc_finish_type (union_type);
chain = 0;
vec_type = make_node (RECORD_TYPE);
tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
size_type_node, &chain);
TREE_NO_WARNING (tmp) = 1;
tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
union_type, &chain);
TREE_NO_WARNING (tmp) = 1;
gfc_finish_type (vec_type);
TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
}
tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
gfc_rank_cst[dim-1]);
vector_types[dim-1] = build_array_type (vec_type, tmp);
return vector_types[dim-1];
}
#include "gt-fortran-trans-types.h"
gcc/fortran/trans-types.h
......@@ -100,5 +100,6 @@ int gfc_is_nodesc_array (gfc_symbol *);
tree gfc_get_dtype (tree);
tree gfc_get_ppc_type (gfc_component *);
tree gfc_get_caf_vector_type (int dim);
#endif
gcc/fortran/trans.h
......@@ -418,6 +418,7 @@ tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
/* trans-expr.c */
void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);
tree gfc_string_to_single_character (tree len, tree str, int kind);
tree gfc_get_tree_for_caf_expr (gfc_expr *);
/* Find the decl containing the auxiliary variables for assigned variables. */
void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr);
......@@ -708,6 +709,9 @@ extern GTY(()) tree gfor_fndecl_caf_this_image;
extern GTY(()) tree gfor_fndecl_caf_num_images;
extern GTY(()) tree gfor_fndecl_caf_register;
extern GTY(()) tree gfor_fndecl_caf_deregister;
extern GTY(()) tree gfor_fndecl_caf_get;
extern GTY(()) tree gfor_fndecl_caf_send;
extern GTY(()) tree gfor_fndecl_caf_sendget;
extern GTY(()) tree gfor_fndecl_caf_critical;
extern GTY(()) tree gfor_fndecl_caf_end_critical;
extern GTY(()) tree gfor_fndecl_caf_sync_all;
......
gcc/testsuite/ChangeLog
2014-06-17 Tobias Burnus <burnus@net-b.de>
Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
* gfortran.dg/coarray/send_array.f90: New.
* gfortran.dg/coarray/get_array.f90: New.
* gfortran.dg/coarray/sendget_array.f90: New.
* gfortran.dg/coarray/collectives_1.f90: Correct subroutine
names.
* gfortran.dg/coarray/collectives_2.f90: New.
2014-06-17 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
PR target/61533
......
gcc/testsuite/gfortran.dg/coarray/collectives_1.f90
......@@ -11,7 +11,7 @@ program test
call test_max
call test_sum
contains
subroutine test_min
subroutine test_max
integer :: val
val = this_image ()
call co_max (val, result_image=1)
......@@ -19,9 +19,9 @@ contains
!write(*,*) "Maximal value", val
if (val /= num_images()) call abort()
end if
end subroutine test_min
end subroutine test_max
subroutine test_max
subroutine test_min
integer :: val
val = this_image ()
call co_min (val, result_image=1)
......@@ -29,7 +29,7 @@ contains
!write(*,*) "Minimal value", val
if (val /= 1) call abort()
end if
end subroutine test_max
end subroutine test_min
subroutine test_sum
integer :: val, n
......
gcc/testsuite/gfortran.dg/coarray/collectives_2.f90 0 → 100644
! { dg-do run }
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
implicit none
intrinsic co_max
intrinsic co_min
intrinsic co_sum
integer :: val(3)
integer :: vec(3)
vec = [2,3,1]
if (this_image() == 1) then
val(1) = 42
else
val(1) = -99
endif
val(2) = this_image()
if (this_image() == num_images()) then
val(3) = -55
else
val(3) = 101
endif
call test_min
call test_max
call test_sum
contains
subroutine test_max
call co_max (val(vec))
!write(*,*) "Maximal value", val
if (num_images() > 1) then
if (any (val /= [42, num_images(), 101])) call abort()
else
if (any (val /= [42, num_images(), -55])) call abort()
endif
end subroutine test_max
subroutine test_min
call co_min (val, result_image=num_images())
if (this_image() == num_images()) then
!write(*,*) "Minimal value", val
if (num_images() > 1) then
if (any (val /= [-99, num_images(), -55])) call abort()
else
if (any (val /= [42, num_images(), -55])) call abort()
endif
endif
end subroutine test_min
subroutine test_sum
integer :: n
call co_sum (val, result_image=1)
if (this_image() == 1) then
n = num_images()
!write(*,*) "The sum is ", val
if (any (val /= [42 + (n-1)*(-99), (n**2 + n)/2, -55+(n-1)*101])) call abort()
end if
end subroutine test_sum
end program test
gcc/testsuite/gfortran.dg/coarray/get_array.f90 0 → 100644
! { dg-do run }
!
! This program does a correctness check for
! ... = ARRAY[idx] and ... = SCALAR[idx]
!
!
! FIXME: two/three has to be modified, test has to be checked and
! diagnostic has to be removed
!
program main
implicit none
integer, parameter :: n = 3
integer, parameter :: m = 4
! Allocatable coarrays
call one(-5, 1)
call one(0, 0)
call one(1, -5)
call one(0, -11)
! Static coarrays
call two()
call three()
contains
subroutine one(lb1, lb2)
integer, value :: lb1, lb2
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, allocatable :: caf(:,:)[:]
integer, allocatable :: a(:,:), b(:,:), c(:,:)
allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
a(lb1:n+lb1-1, lb2:m+lb2-1), &
b(lb1:n+lb1-1, lb2:m+lb2-1), &
c(lb1:n+lb1-1, lb2:m+lb2-1))
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
c(:,:) = caf(:,:)[num_images()]
if (any (a /= c)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
if (any (a /= c)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (c /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine one
subroutine two()
integer, parameter :: lb1 = -5, lb2 = 1
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: c(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
c(:,:) = caf(:,:)[num_images()]
if (any (a /= c)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
if (any (a /= c)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (c /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine two
subroutine three()
integer, parameter :: lb1 = 0, lb2 = 0
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: c(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
c(:,:) = caf(:,:)[num_images()]
if (any (a /= c)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
c(i,j) = caf(i,j)[num_images()]
end do
end do
if (any (a /= c)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
c = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (c /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine three
end program main
gcc/testsuite/gfortran.dg/coarray/sendget_array.f90 0 → 100644
! { dg-do run }
!
! This program does a correctness check for
! ARRAY[idx] = ARRAY[idx] and SCALAR[idx] = SCALAR[idx]
!
!
! FIXME: two/three has to be modified, test has to be checked and
! diagnostic has to be removed
!
program main
implicit none
integer, parameter :: n = 3
integer, parameter :: m = 4
! Allocatable coarrays
call one(-5, 1)
call one(0, 0)
call one(1, -5)
call one(0, -11)
! Static coarrays
call two()
call three()
contains
subroutine one(lb1, lb2)
integer, value :: lb1, lb2
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, allocatable :: caf(:,:)[:], caf2(:,:)[:]
integer, allocatable :: a(:,:), b(:,:)
allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
a(lb1:n+lb1-1, lb2:m+lb2-1), &
b(lb1:n+lb1-1, lb2:m+lb2-1))
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
caf2(:,:)[this_image()] = caf(:,:)[num_images()]
if (any (a /= caf2)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
if (any (a /= caf2)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (caf2 /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine one
subroutine two()
integer, parameter :: lb1 = -5, lb2 = 1
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
caf2(:,:)[this_image()] = caf(:,:)[num_images()]
if (any (a /= caf2)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
if (any (a /= caf2)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (caf2 /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine two
subroutine three()
integer, parameter :: lb1 = 0, lb2 = 0
integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*]
integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
b = reshape([(i*33, i = 1, size(b))], shape(b))
! Whole array: ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(:,:) = b(:,:)
caf2(:,:)[this_image()] = caf(:,:)[num_images()]
if (any (a /= caf2)) then
call abort()
end if
! Scalar assignment
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
do j = lb2, m+lb2-1
do i = n+lb1-1, lb1, -2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
do j = lb2, m+lb2-1
do i = lb1, n+lb1-1, 2
a(i,j) = b(i,j)
caf2(i,j)[this_image()] = caf(i,j)[num_images()]
end do
end do
if (any (a /= caf2)) then
call abort()
end if
! Array sections with different ranges and pos/neg strides
do i_sgn1 = -1, 1, 2
do i_sgn2 = -1, 1, 2
do i=lb1, n+lb1-1
do i_e=lb1, n+lb1-1
do i_s=1, n
do j=lb2, m+lb2-1
do j_e=lb2, m+lb2-1
do j_s=1, m
! ARRAY = ARRAY
caf = -42
a = -42
caf2 = -42
if (this_image() == num_images()) then
caf(:,:) = b(:,:)
endif
sync all
a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
= b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] &
= caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
if (any (caf2 /= a)) then
call abort()
end if
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine three
end program main
libgfortran/ChangeLog
2014-06-17 Tobias Burnus <burnus@net-b.de>
* caf/libcaf.h (gfc_descriptor_t): New typedef.
(caf_vector_t): Update.
(_gfortran_caf_co_sum, _gfortran_caf_co_max, _gfortran_caf_co_min):
Remove vector-subscript argument.
(_gfortran_caf_co_send, _gfortran_caf_co_get,
_gfortran_caf_co_sendget): New.
* caf/single.c (_gfortran_caf_co_sum, _gfortran_caf_co_max,
_gfortran_caf_co_min): Remove vector-subscript argument.
(_gfortran_caf_co_send, _gfortran_caf_co_get,
_gfortran_caf_co_sendget): New.
2014-06-17 Janne Blomqvist <jb@gcc.gnu.org>
* libgfortran.h (xmallocarray): New prototype.
......
libgfortran/caf/libcaf.h
......@@ -30,6 +30,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include <stddef.h> /* For size_t. */
#include <stdint.h> /* For int32_t. */
#include "libgfortran.h"
#if 0
#ifndef __GNUC__
#define __attribute__(x)
#define likely(x) (x)
......@@ -45,6 +48,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#define STAT_LOCKED 1
#define STAT_LOCKED_OTHER_IMAGE 2
#define STAT_STOPPED_IMAGE 6000
#endif
/* Describes what type of array we are registerring. Keep in sync with
gcc/fortran/trans.h. */
......@@ -57,6 +61,7 @@ typedef enum caf_register_t {
caf_register_t;
typedef void* caf_token_t;
typedef gfc_array_void gfc_descriptor_t;
/* Linked list of static coarrays registered. */
typedef struct caf_static_t {
......@@ -65,13 +70,19 @@ typedef struct caf_static_t {
}
caf_static_t;
/* When there is a vector subscript in this dimension, nvec == 0, otherwise,
lower_bound, upper_bound, stride contains the bounds relative to the declared
bounds; kind denotes the integer kind of the elements of vector[]. */
typedef struct caf_vector_t {
size_t nvec; /* size of the vector; 0 means dim triplet. */
size_t nvec;
union {
struct {
void *vector;
int kind;
} v;
struct {
ptrdiff_t lower_bound, upper_bound, stride;
} triplet;
ptrdiff_t *vector;
} u;
}
caf_vector_t;
......@@ -103,10 +114,18 @@ void _gfortran_caf_error_stop_str (const char *, int32_t)
__attribute__ ((noreturn));
void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn));
void _gfortran_caf_co_sum (void *, caf_vector_t *, int, int *, char *, int);
void _gfortran_caf_co_min (void *, caf_vector_t *, int, int *, char *, int,
int);
void _gfortran_caf_co_max (void *, caf_vector_t *, int, int *, char *, int,
int);
void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *,
char *, int);
void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *,
int, int);
void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *,
int, int);
void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, gfc_descriptor_t *, int, int);
void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, gfc_descriptor_t *, int, int);
void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, caf_token_t, size_t, int,
gfc_descriptor_t *, caf_vector_t *, int, int);
#endif /* LIBCAF_H */
libgfortran/caf/single.c
......@@ -205,8 +205,7 @@ _gfortran_caf_error_stop (int32_t error)
void
_gfortran_caf_co_sum (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
......@@ -216,8 +215,7 @@ _gfortran_caf_co_sum (void *a __attribute__ ((unused)),
}
void
_gfortran_caf_co_min (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
_gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int src_len __attribute__ ((unused)),
......@@ -228,8 +226,7 @@ _gfortran_caf_co_min (void *a __attribute__ ((unused)),
}
void
_gfortran_caf_co_max (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
_gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int src_len __attribute__ ((unused)),
......@@ -238,3 +235,234 @@ _gfortran_caf_co_max (void *a __attribute__ ((unused)),
if (stat)
stat = 0;
}
void
_gfortran_caf_get (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
gfc_descriptor_t *src ,
caf_vector_t *src_vector __attribute__ ((unused)),
gfc_descriptor_t *dest, int src_kind, int dst_kind)
{
/* FIXME: Handle vector subscript, type conversion and assignment "array = scalar".
check in particular whether strings of different kinds are permitted and
whether it makes sense to handle array = scalar. */
size_t i, k, size;
int j;
int rank = GFC_DESCRIPTOR_RANK (dest);
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
if (rank == 0)
{
void *sr = (void *) ((char *) TOKEN (token) + offset);
if (dst_kind == src_kind)
memmove (GFC_DESCRIPTOR_DATA (dest), sr,
dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
if (dst_kind == 1)
memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size, ' ',
dst_size-src_size);
else /* dst_kind == 4. */
for (i = src_size/4; i < dst_size/4; i++)
((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t)' ';
}
return;
}
size = 1;
for (j = 0; j < rank; j++)
{
ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
if (dimextent < 0)
dimextent = 0;
size *= dimextent;
}
if (size == 0)
return;
for (i = 0; i < size; i++)
{
ptrdiff_t array_offset_dst = 0;
ptrdiff_t stride = 1;
ptrdiff_t extent = 1;
for (j = 0; j < rank-1; j++)
{
array_offset_dst += ((i / (extent*stride))
% (dest->dim[j]._ubound
- dest->dim[j].lower_bound + 1))
* dest->dim[j]._stride;
extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
stride = dest->dim[j]._stride;
}
array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
void *sr;
if (GFC_DESCRIPTOR_RANK (src) != 0)
{
ptrdiff_t array_offset_sr = 0;
stride = 1;
extent = 1;
for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
{
array_offset_sr += ((i / (extent*stride))
% (src->dim[j]._ubound
- src->dim[j].lower_bound + 1))
* src->dim[j]._stride;
extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
stride = src->dim[j]._stride;
}
array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
sr = (void *)((char *) TOKEN (token) + offset
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
}
else
sr = (void *)((char *) TOKEN (token) + offset);
if (dst_kind == src_kind)
memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
if (dst_kind == 1)
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
else /* dst_kind == 4. */
for (k = src_size/4; k < dst_size/4; i++)
((int32_t*) dst)[i] = (int32_t)' ';
}
}
}
void
_gfortran_caf_send (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
gfc_descriptor_t *dest,
caf_vector_t *dst_vector __attribute__ ((unused)),
gfc_descriptor_t *src, int dst_kind,
int src_kind __attribute__ ((unused)))
{
/* FIXME: Handle vector subscript, type conversion and assignment "array = scalar".
check in particular whether strings of different kinds are permitted. */
size_t i, k, size;
int j;
int rank = GFC_DESCRIPTOR_RANK (dest);
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
if (rank == 0)
{
void *dst = (void *) ((char *) TOKEN (token) + offset);
if (dst_kind == src_kind)
memmove (dst, GFC_DESCRIPTOR_DATA (src),
dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
if (dst_kind == 1)
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
else /* dst_kind == 4. */
for (i = src_size/4; i < dst_size/4; i++)
((int32_t*) dst)[i] = (int32_t)' ';
}
return;
}
size = 1;
for (j = 0; j < rank; j++)
{
ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
if (dimextent < 0)
dimextent = 0;
size *= dimextent;
}
if (size == 0)
return;
#if 0
if (dst_len == src_len && PREFIX (is_contiguous) (dest)
&& PREFIX (is_contiguous) (src))
{
void *dst = (void *)((char *) TOKEN (token) + offset);
memmove (dst, src->base_addr, GFC_DESCRIPTOR_SIZE (dest)*size);
return;
}
#endif
for (i = 0; i < size; i++)
{
ptrdiff_t array_offset_dst = 0;
ptrdiff_t stride = 1;
ptrdiff_t extent = 1;
for (j = 0; j < rank-1; j++)
{
array_offset_dst += ((i / (extent*stride))
% (dest->dim[j]._ubound
- dest->dim[j].lower_bound + 1))
* dest->dim[j]._stride;
extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
stride = dest->dim[j]._stride;
}
array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
void *dst = (void *)((char *) TOKEN (token) + offset
+ array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
void *sr;
if (GFC_DESCRIPTOR_RANK (src) != 0)
{
ptrdiff_t array_offset_sr = 0;
stride = 1;
extent = 1;
for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
{
array_offset_sr += ((i / (extent*stride))
% (src->dim[j]._ubound
- src->dim[j].lower_bound + 1))
* src->dim[j]._stride;
extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
stride = src->dim[j]._stride;
}
array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
sr = (void *)((char *) src->base_addr
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
}
else
sr = src->base_addr;
if (dst_kind == src_kind)
memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
/* else: FIXME: type conversion. */
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
if (dst_kind == 1)
memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
else /* dst_kind == 4. */
for (k = src_size/4; k < dst_size/4; i++)
((int32_t*) dst)[i] = (int32_t)' ';
}
}
}
void
_gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
int dst_image_index, gfc_descriptor_t *dest,
caf_vector_t *dst_vector, caf_token_t src_token,
size_t src_offset,
int src_image_index __attribute__ ((unused)),
gfc_descriptor_t *src,
caf_vector_t *src_vector __attribute__ ((unused)),
int dst_len, int src_len)
{
/* FIXME: Handle vector subscript of 'src_vector'. */
/* For a single image, src->base_addr should be the same as src_token + offset
but to play save, we do it properly. */
void *src_base = GFC_DESCRIPTOR_DATA (src);
GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
_gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
src, dst_len, src_len);
GFC_DESCRIPTOR_DATA (src) = src_base;
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment