Hello, as promised, I submit the patch (split to 5 pieces) adding support for assumed rank actual arguments to the LBOUND/UBOUND/SHAPE intrinsics in the non-scalar case (without the DIM argument).
Patch 1: Disable shape setting and simplification for assumed rank. Patch 2: Move and rename get_rank_from_desc to gfc_conv_descriptor_rank. Patch 3: Fix set_loop_bounds #1 (optional). Patch 4: Fix set_loop_bounds #2. Patch 5: Properly setup the scalarizer in the {l,u}bound(assumed_rank) cases. More details in the patch files. Regression tested on x86_64-unknown-linux-gnu. OK for trunk? Mikael
the shape was incorrectly set to -1 at resolution time for those intrinsics. This patch disables it. Also disabled is the attempt to simplify shape in the assumed rank case. {l,u}bound didn't need this; it was already done. 2012-08-02 Mikael Morin <mik...@gcc.gnu.org> * iresolve.c (resolve_bound, gfc_resolve_shape): Don't set the shape for assumed rank arrays. * simplify.c (gfc_simplify_shape): Don't try to simplify if the argument is assumed rank. diff --git a/iresolve.c b/iresolve.c index 6d1e8b2..3ebf0c0 100644 --- a/iresolve.c +++ b/iresolve.c @@ -134,9 +134,12 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, if (dim == NULL) { f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) - : array->rank); + if (array->rank != -1) + { + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) + : array->rank); + } } f->value.function.name = xstrdup (name); @@ -2225,8 +2228,12 @@ gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind) f->ts.kind = gfc_default_integer_kind; f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); + if (array->rank != -1) + { + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], array->rank); + } + f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind); } diff --git a/simplify.c b/simplify.c index c12675e..e4ccddf 100644 --- a/simplify.c +++ b/simplify.c @@ -5470,6 +5470,9 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) gfc_try t; int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); + if (source->rank == -1) + return NULL; + result = gfc_get_array_expr (BT_INTEGER, k, &source->where); if (source->rank == 0)
The final patch (number 5) needs to access the rank from the descriptor. Thus, trans-intrinsic.c's get_rank_from_desc should be made public. I took the opportunity to move it in trans-array.c and rename it in line with other descriptor accessors (gfc_conv_descriptor_rank). 2012-08-02 Mikael Morin <mik...@gcc.gnu.org> * trans-array.h (gfc_conv_descriptor_rank): New prototype. * trans-array.c (gfc_conv_descriptor_rank): New function moved and renamed ... * trans-intrinsic.c (gfc_get_rank_from_desc): ... from this one. (gfc_conv_intrinsic_rank, gfc_conv_intrinsic_bound, gfc_conv_associated): Update calls. diff --git a/trans-array.c b/trans-array.c index 555d696..abdb9ea 100644 --- a/trans-array.c +++ b/trans-array.c @@ -249,6 +249,20 @@ gfc_conv_descriptor_dtype (tree desc) tree +gfc_conv_descriptor_rank (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), + dtype, tmp); + return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); +} + + +tree gfc_get_descriptor_dimension (tree desc) { tree type, field; diff --git a/trans-array.h b/trans-array.h index b7ab806..5ad794a 100644 --- a/trans-array.h +++ b/trans-array.h @@ -154,6 +154,7 @@ tree gfc_conv_descriptor_data_get (tree); tree gfc_conv_descriptor_data_addr (tree); tree gfc_conv_descriptor_offset_get (tree); tree gfc_conv_descriptor_dtype (tree); +tree gfc_conv_descriptor_rank (tree); tree gfc_get_descriptor_dimension (tree); tree gfc_conv_descriptor_stride_get (tree, tree); tree gfc_conv_descriptor_lbound_get (tree, tree); diff --git a/trans-intrinsic.c b/trans-intrinsic.c index 7bcfda9..fac29c7 100644 --- a/trans-intrinsic.c +++ b/trans-intrinsic.c @@ -1315,20 +1315,6 @@ trans_num_images (gfc_se * se) } -static tree -get_rank_from_desc (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); - tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), - dtype, tmp); - return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); -} - - static void gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) { @@ -1345,7 +1331,7 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - se->expr = get_rank_from_desc (argse.expr); + se->expr = gfc_conv_descriptor_rank (argse.expr); } @@ -1434,7 +1420,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, bound, build_int_cst (TREE_TYPE (bound), 0)); if (as && as->type == AS_ASSUMED_RANK) - tmp = get_rank_from_desc (desc); + tmp = gfc_conv_descriptor_rank (desc); else tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, @@ -5895,7 +5881,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_conv_expr_lhs (&arg1se, arg1->expr); if (arg1->expr->rank == -1) { - tmp = get_rank_from_desc (arg1se.expr); + tmp = gfc_conv_descriptor_rank (arg1se.expr); tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp, gfc_index_one_node); }
The final patch needs adjustments in set_loop_bounds. I took the opportunity to do some bugfixes in that area. Those are not absolutely needed for {l,u}bound and shape support though. The first hunk removes a n >= loop->dimen condition. Since the coarray handling has been moved out of the scalarizer, this condition is always false. The second hunk is possibly more controversial and could be backed out if that's preferred. It changes the code so that it matches the comment before it. Namely, we prefer having a loop specifier with strides of one . However, the code first checks if the current boundspec is better than the one chosen so far WRT strides, and if not falls back to check if there is an improvement WRT lower bounds, but doesn't check that it doesn't make things worse WRT strides. This second hunk adds the missing checks. 2012-08-02 Mikael Morin <mik...@gcc.gnu.org> * trans-array.c (set_loop_bounds): Remove useless dimension check. Don't update loopspec if it would lose the wanted stride criterium. diff --git a/trans-array.c b/trans-array.c index abdb9ea..feb35df 100644 --- a/trans-array.c +++ b/trans-array.c @@ -4469,8 +4469,7 @@ set_loop_bounds (gfc_loopinfo *loop) known lower bound known upper bound */ - else if ((loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) - || n >= loop->dimen) + else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) loopspec[n] = ss; else if (integer_onep (info->stride[dim]) && !integer_onep (specinfo->stride[spec_dim])) @@ -4479,7 +4478,11 @@ set_loop_bounds (gfc_loopinfo *loop) && !INTEGER_CST_P (specinfo->stride[spec_dim])) loopspec[n] = ss; else if (INTEGER_CST_P (info->start[dim]) - && !INTEGER_CST_P (specinfo->start[spec_dim])) + && !INTEGER_CST_P (specinfo->start[spec_dim]) + && integer_onep (info->stride[dim]) + == integer_onep (specinfo->stride[dim]) + && INTEGER_CST_P (info->stride[dim]) + == INTEGER_CST_P (specinfo->stride[dim])) loopspec[n] = ss; /* We don't work out the upper bound. else if (INTEGER_CST_P (info->finish[n])
Another patch changing set_loop_bounds; this one (or at least a variant of it) is really needed for {l,u}bound support. We have some cases where there is nothing but an intrinsic specifying the loop bounds (think of print *, ubound(assumed_rank)), so we need to choose that loopspec in that case at least. Previously the {l,u}bound and shape intrinsics had always a known shape, and thus were automatically preferred for specifying the loop bounds. Now if the shape is unknown we end up choosing no loopspec at all. This patch allows non-array-sections to pass through the conditions modified in the previous patch. It also removes a condition always preferring function calls for the choice of loopspec. Both are made under the assumption that the conditions modified in the previous patch always make sense; not only for array section. The patch could be made more conservative by adding an intrinsic-specific bypass choosing the intrinsic boundspec only if there is no other. 2012-08-02 Mikael Morin <mik...@gcc.gnu.org> * trans-array.c (set_loop_bounds): Allow non-array-section to be chosen using the stride and lower bound criteria. diff --git a/trans-array.c b/trans-array.c index feb35df..b799e24 100644 --- a/trans-array.c +++ b/trans-array.c @@ -4444,22 +4444,11 @@ set_loop_bounds (gfc_loopinfo *loop) continue; } - /* TODO: Pick the best bound if we have a choice between a - function and something else. */ - if (ss_type == GFC_SS_FUNCTION) - { - loopspec[n] = ss; - continue; - } - /* Avoid using an allocatable lhs in an assignment, since there might be a reallocation coming. */ if (loopspec[n] && ss->is_alloc_lhs) continue; - if (ss_type != GFC_SS_SECTION) - continue; - if (!loopspec[n]) loopspec[n] = ss; /* Criteria for choosing a loop specifier (most important first):
This part finally uses the rank to setup the intrinsic boundspec in gfc_conv_ss_startstride and uses the intrinsic boundspec to set the upper bound in set_loop_bounds. There is no additional code; with this the scalarizer is properly setup and calls appropriately the code previously modified by Tobias to handle the DIM= version of the {l,u}bound and shape intrinsics. 2012-08-02 Mikael Morin <mik...@gcc.gnu.org> * trans-array.c (gfc_conv_ss_startstride): Set the intrinsic result's lower and upper bounds according to the rank. (set_loop_bounds): Set the loop upper bound in the intrinsic case. diff --git a/trans-array.c b/trans-array.c index b799e24..187eab0 100644 --- a/trans-array.c +++ b/trans-array.c @@ -3808,6 +3808,40 @@ done: /* Fall through to supply start and stride. */ case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + { + gfc_expr *arg; + + /* This is the variant without DIM=... */ + gcc_assert (expr->value.function.actual->next->expr == NULL); + + arg = expr->value.function.actual->expr; + if (arg->rank == -1) + { + gfc_se se; + tree rank, tmp; + + /* The rank (hence the return value's shape) is unknown, + we have to retrieve it. */ + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + gfc_conv_expr (&se, arg); + /* This is a bare variable, so there is no preliminary + or cleanup code. */ + gcc_assert (se.pre.head == NULL_TREE + && se.post.head == NULL_TREE); + rank = gfc_conv_descriptor_rank (se.expr); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, + rank), + gfc_index_one_node); + info->end[0] = gfc_evaluate_now (tmp, &loop->pre); + info->start[0] = gfc_index_zero_node; + info->stride[0] = gfc_index_one_node; + continue; + } + /* Otherwise fall through GFC_SS_FUNCTION. */ + } case GFC_ISYM_LCOBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_THIS_IMAGE: @@ -4526,6 +4560,20 @@ set_loop_bounds (gfc_loopinfo *loop) gcc_assert (loop->to[n] == NULL_TREE); break; + case GFC_SS_INTRINSIC: + { + gfc_expr *expr = loopspec[n]->info->expr; + + /* The {l,u}bound of an assumed rank. */ + gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND + || expr->value.function.isym->id == GFC_ISYM_UBOUND) + && expr->value.function.actual->next->expr == NULL + && expr->value.function.actual->expr->rank == -1); + + loop->to[n] = info->end[dim]; + break; + } + default: gcc_unreachable (); }
! { dg-do run } ! ! Test the behaviour of lbound, ubound of shape with assumed rank arguments ! in an array context (without DIM argument). ! program test integer :: a(2:4,-2:5) integer, allocatable :: b(:,:) integer, pointer :: c(:,:) character(52) :: buffer call foo(a) allocate(b(2:4,-2:5)) call foo(b) call bar(b) allocate(c(2:4,-2:5)) call foo(c) call baz(c) contains subroutine foo(arg) integer :: arg(..) !print *, lbound(arg) !print *, id(lbound(arg)) if (any(lbound(arg) /= [1, 1])) call abort if (any(id(lbound(arg)) /= [1, 1])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) lbound(arg) if (buffer /= ' 1 1') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(lbound(arg)) if (buffer /= ' 1 1') call abort !print *, ubound(arg) !print *, id(ubound(arg)) if (any(ubound(arg) /= [3, 8])) call abort if (any(id(ubound(arg)) /= [3, 8])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) ubound(arg) if (buffer /= ' 3 8') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(ubound(arg)) if (buffer /= ' 3 8') call abort !print *, shape(arg) !print *, id(shape(arg)) if (any(shape(arg) /= [3, 8])) call abort if (any(id(shape(arg)) /= [3, 8])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) shape(arg) if (buffer /= ' 3 8') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(shape(arg)) if (buffer /= ' 3 8') call abort end subroutine foo subroutine bar(arg) integer, allocatable :: arg(:,:) !print *, lbound(arg) !print *, id(lbound(arg)) if (any(lbound(arg) /= [2, -2])) call abort if (any(id(lbound(arg)) /= [2, -2])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) lbound(arg) if (buffer /= ' 2 -2') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(lbound(arg)) if (buffer /= ' 2 -2') call abort !print *, ubound(arg) !print *, id(ubound(arg)) if (any(ubound(arg) /= [4, 5])) call abort if (any(id(ubound(arg)) /= [4, 5])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) ubound(arg) if (buffer /= ' 4 5') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(ubound(arg)) if (buffer /= ' 4 5') call abort !print *, shape(arg) !print *, id(shape(arg)) if (any(shape(arg) /= [3, 8])) call abort if (any(id(shape(arg)) /= [3, 8])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) shape(arg) if (buffer /= ' 3 8') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(shape(arg)) if (buffer /= ' 3 8') call abort end subroutine bar subroutine baz(arg) integer, pointer :: arg(..) !print *, lbound(arg) !print *, id(lbound(arg)) if (any(lbound(arg) /= [2, -2])) call abort if (any(id(lbound(arg)) /= [2, -2])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) lbound(arg) if (buffer /= ' 2 -2') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(lbound(arg)) if (buffer /= ' 2 -2') call abort !print *, ubound(arg) !print *, id(ubound(arg)) if (any(ubound(arg) /= [4, 5])) call abort if (any(id(ubound(arg)) /= [4, 5])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) ubound(arg) if (buffer /= ' 4 5') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(ubound(arg)) if (buffer /= ' 4 5') call abort !print *, shape(arg) !print *, id(shape(arg)) if (any(shape(arg) /= [3, 8])) call abort if (any(id(shape(arg)) /= [3, 8])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) shape(arg) if (buffer /= ' 3 8') call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) id(shape(arg)) if (buffer /= ' 3 8') call abort end subroutine baz elemental function id(arg) integer, intent(in) :: arg integer :: id id = arg end function id end program test
! { dg-do run } ! ! Test the behaviour of lbound, ubound of shape with assumed rank arguments ! in an array context (without DIM argument). ! program test integer :: a(2:4,-2:5) integer, allocatable :: b(:,:) integer, allocatable :: c(:,:) integer, pointer :: d(:,:) character(52) :: buffer b = foo(a) !print *,b(:,1) if (any(b(:,1) /= [11, 101])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,1) if (buffer /= ' 11 101') call abort !print *,b(:,2) if (any(b(:,2) /= [3, 8])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,2) if (buffer /= ' 3 8') call abort !print *,b(:,3) if (any(b(:,3) /= [13, 108])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,3) if (buffer /= ' 13 108') call abort allocate(c(1:2,-3:6)) b = bar(c) !print *,b(:,1) if (any(b(:,1) /= [11, 97])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,1) if (buffer /= ' 11 97') call abort !print *,b(:,2) if (any(b(:,2) /= [12, 106])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,2) if (buffer /= ' 12 106') call abort !print *,b(:,3) if (any(b(:,3) /= [2, 10])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,3) if (buffer /= ' 2 10') call abort allocate(d(3:5,-1:10)) b = baz(d) !print *,b(:,1) if (any(b(:,1) /= [3, -1])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,1) if (buffer /= ' 3 -1') call abort !print *,b(:,2) if (any(b(:,2) /= [15, 110])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,2) if (buffer /= ' 15 110') call abort !print *,b(:,3) if (any(b(:,3) /= [13, 112])) call abort buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' write(buffer,*) b(:,3) if (buffer /= ' 13 112') call abort contains function foo(arg) result(res) integer :: arg(..) integer, allocatable :: res(:,:) allocate(res(rank(arg), 3)) res(:,1) = lbound(arg) + (/ 10, 100 /) res(:,2) = ubound(arg) res(:,3) = (/ 10, 100 /) + shape(arg) end function foo function bar(arg) result(res) integer, allocatable :: arg(..) integer, allocatable :: res(:,:) allocate(res(-1:rank(arg)-2, 3)) res(:,1) = lbound(arg) + (/ 10, 100 /) res(:,2) = (/ 10, 100 /) + ubound(arg) res(:,3) = shape(arg) end function bar function baz(arg) result(res) integer, pointer :: arg(..) integer, allocatable :: res(:,:) allocate(res(2:rank(arg)+1, 3)) res(:,1) = lbound(arg) res(:,2) = (/ 10, 100 /) + ubound(arg) res(:,3) = shape(arg) + (/ 10, 100 /) end function baz end program test