From patchwork Wed Jul 28 17:12:34 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 60163 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 1FF62B6EFF for ; Thu, 29 Jul 2010 03:07:48 +1000 (EST) Received: (qmail 25329 invoked by alias); 28 Jul 2010 17:07:45 -0000 Received: (qmail 25099 invoked by uid 22791); 28 Jul 2010 17:07:41 -0000 X-SWARE-Spam-Status: No, hits=-2.5 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS X-Spam-Check-By: sourceware.org Received: from tatiana.utanet.at (HELO tatiana.utanet.at) (213.90.36.46) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 28 Jul 2010 17:07:31 +0000 Received: from plenty.xoc.tele2net.at ([213.90.36.8]) by tatiana.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OeA6K-0005Ws-KC; Wed, 28 Jul 2010 19:07:28 +0200 Received: from d86-33-51-38.cust.tele2.at ([86.33.51.38] helo=[192.168.1.18]) by plenty.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OeA6K-00073y-6G; Wed, 28 Jul 2010 19:07:28 +0200 Message-ID: <4C506502.3010808@domob.eu> Date: Wed, 28 Jul 2010 19:12:34 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Tobias Burnus CC: Fortran List , gcc-patches Subject: Re: [Patch, Fortran] Some simplification for ?BOUND/SHAPE/SIZE and non-variable expressions References: <4C50311B.4080009@domob.eu> <4C504B02.4020908@net-b.de> In-Reply-To: <4C504B02.4020908@net-b.de> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Tobias Burnus wrote: > On 07/28/2010 03:31 PM, Daniel Kraft wrote: >> Regression-testing at the moment on GNU/Linux-x86-32. Ok for trunk if >> no failures? > > OK, but you could consider the following: Thanks! I've committed the attached patch as discussed on IRC as rev. 162648. Yours, Daniel Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 162619) +++ gcc/fortran/gfortran.h (working copy) @@ -2691,6 +2691,8 @@ bool gfc_get_corank (gfc_expr *); bool gfc_has_ultimate_allocatable (gfc_expr *); bool gfc_has_ultimate_pointer (gfc_expr *); +gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...); + /* st.c */ extern gfc_code new_st; Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 162619) +++ gcc/fortran/expr.c (working copy) @@ -4199,3 +4199,47 @@ gfc_is_simply_contiguous (gfc_expr *expr return true; } + + +/* Build call to an intrinsic procedure. The number of arguments has to be + passed (rather than ending the list with a NULL value) because we may + want to add arguments but with a NULL-expression. */ + +gfc_expr* +gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...) +{ + gfc_expr* result; + gfc_actual_arglist* atail; + gfc_intrinsic_sym* isym; + va_list ap; + unsigned i; + + isym = gfc_find_function (name); + gcc_assert (isym); + + result = gfc_get_expr (); + result->expr_type = EXPR_FUNCTION; + result->ts = isym->ts; + result->where = where; + gfc_get_ha_sym_tree (isym->name, &result->symtree); + result->value.function.name = name; + result->value.function.isym = isym; + + va_start (ap, numarg); + atail = NULL; + for (i = 0; i < numarg; ++i) + { + if (atail) + { + atail->next = gfc_get_actual_arglist (); + atail = atail->next; + } + else + atail = result->value.function.actual = gfc_get_actual_arglist (); + + atail->expr = va_arg (ap, gfc_expr*); + } + va_end (ap); + + return result; +} Index: gcc/fortran/simplify.c =================================================================== --- gcc/fortran/simplify.c (revision 162619) +++ gcc/fortran/simplify.c (working copy) @@ -73,6 +73,9 @@ range_check (gfc_expr *result, const cha if (result == NULL) return &gfc_bad_expr; + if (result->expr_type != EXPR_CONSTANT) + return result; + switch (gfc_range_check (result)) { case ARITH_OK: @@ -2727,24 +2730,52 @@ simplify_bound_dim (gfc_expr *array, gfc gfc_expr *l, *u, *result; int k; + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + + /* For non-variables, LBOUND(expr, DIM=n) = 1 and + UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ + if (!coarray && array->expr_type != EXPR_VARIABLE) + { + if (upper) + { + gfc_expr* dim = result; + mpz_set_si (dim->value.integer, d); + + result = gfc_simplify_size (array, dim, kind); + gfc_free_expr (dim); + if (!result) + goto returnNull; + } + else + mpz_set_si (result->value.integer, 1); + + goto done; + } + + /* Otherwise, we have a variable expression. */ + gcc_assert (array->expr_type == EXPR_VARIABLE); + gcc_assert (as); + /* The last dimension of an assumed-size array is special. */ if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) || (coarray && d == as->rank + as->corank)) { if (as->lower[d-1]->expr_type == EXPR_CONSTANT) - return gfc_copy_expr (as->lower[d-1]); - else - return NULL; - } + { + gfc_free_expr (result); + return gfc_copy_expr (as->lower[d-1]); + } - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; + goto returnNull; + } result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - /* Then, we need to know the extent of the given dimension. */ if (coarray || ref->u.ar.type == AR_FULL) { @@ -2753,7 +2784,7 @@ simplify_bound_dim (gfc_expr *array, gfc if (l->expr_type != EXPR_CONSTANT || u == NULL || u->expr_type != EXPR_CONSTANT) - return NULL; + goto returnNull; if (mpz_cmp (l->value.integer, u->value.integer) > 0) { @@ -2778,13 +2809,18 @@ simplify_bound_dim (gfc_expr *array, gfc { if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer) != SUCCESS) - return NULL; + goto returnNull; } else mpz_set_si (result->value.integer, (long int) 1); } +done: return range_check (result, upper ? "UBOUND" : "LBOUND"); + +returnNull: + gfc_free_expr (result); + return NULL; } @@ -2796,7 +2832,11 @@ simplify_bound (gfc_expr *array, gfc_exp int d; if (array->expr_type != EXPR_VARIABLE) - return NULL; + { + as = NULL; + ref = NULL; + goto done; + } /* Follow any component references. */ as = array->symtree->n.sym->as; @@ -2815,7 +2855,7 @@ simplify_bound (gfc_expr *array, gfc_exp /* We're done because 'as' has already been set in the previous iteration. */ if (!ref->next) - goto done; + goto done; /* Fall through. */ @@ -2842,7 +2882,7 @@ simplify_bound (gfc_expr *array, gfc_exp done: - if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) return NULL; if (dim == NULL) @@ -2853,7 +2893,7 @@ simplify_bound (gfc_expr *array, gfc_exp int k; /* UBOUND(ARRAY) is not valid for an assumed-size array. */ - if (upper && as->type == AS_ASSUMED_SIZE) + if (upper && as && as->type == AS_ASSUMED_SIZE) { /* An error message will be emitted in check_assumed_size_reference (resolve.c). */ @@ -2904,8 +2944,8 @@ simplify_bound (gfc_expr *array, gfc_exp d = mpz_get_si (dim->value.integer); - if (d < 1 || d > as->rank - || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper)) + if (d < 1 || d > array->rank + || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) { gfc_error ("DIM argument at %L is out of bounds", &dim->where); return &gfc_bad_expr; @@ -4728,15 +4768,25 @@ gfc_simplify_shape (gfc_expr *source) return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &source->where); - if (source->expr_type != EXPR_VARIABLE) - return NULL; - result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &source->where); - ar = gfc_find_array_ref (source); - - t = gfc_array_ref_shape (ar, shape); + if (source->expr_type == EXPR_VARIABLE) + { + ar = gfc_find_array_ref (source); + t = gfc_array_ref_shape (ar, shape); + } + else if (source->shape) + { + t = SUCCESS; + for (n = 0; n < source->rank; n++) + { + mpz_init (shape[n]); + mpz_set (shape[n], source->shape[n]); + } + } + else + t = FAILURE; for (n = 0; n < source->rank; n++) { @@ -4760,9 +4810,7 @@ gfc_simplify_shape (gfc_expr *source) return NULL; } else - { - e = f; - } + e = f; } gfc_constructor_append_expr (&result->value.constructor, e, NULL); @@ -4782,6 +4830,56 @@ gfc_simplify_size (gfc_expr *array, gfc_ if (k == -1) return &gfc_bad_expr; + /* For unary operations, the size of the result is given by the size + of the operand. For binary ones, it's the size of the first operand + unless it is scalar, then it is the size of the second. */ + if (array->expr_type == EXPR_OP && !array->value.op.uop) + { + gfc_expr* replacement; + gfc_expr* simplified; + + switch (array->value.op.op) + { + /* Unary operations. */ + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + replacement = array->value.op.op1; + break; + + /* Binary operations. If any one of the operands is scalar, take + the other one's size. If both of them are arrays, it does not + matter -- try to find one with known shape, if possible. */ + default: + if (array->value.op.op1->rank == 0) + replacement = array->value.op.op2; + else if (array->value.op.op2->rank == 0) + replacement = array->value.op.op1; + else + { + simplified = gfc_simplify_size (array->value.op.op1, dim, kind); + if (simplified) + return simplified; + + replacement = array->value.op.op2; + } + break; + } + + /* Try to reduce it directly if possible. */ + simplified = gfc_simplify_size (replacement, dim, kind); + + /* Otherwise, we build a new SIZE call. This is hopefully at least + simpler than the original one. */ + if (!simplified) + simplified = gfc_build_intrinsic_call ("size", array->where, 3, + gfc_copy_expr (replacement), + gfc_copy_expr (dim), + gfc_copy_expr (kind)); + + return simplified; + } + if (dim == NULL) { if (gfc_array_size (array, &size) == FAILURE) Index: gcc/testsuite/gfortran.dg/bound_8.f90 =================================================================== --- gcc/testsuite/gfortran.dg/bound_8.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/bound_8.f90 (revision 0) @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries -fall-intrinsics" } + +! Check that LBOUND/UBOUND/SIZE/SHAPE of array-expressions get simplified +! in certain cases. +! There should no array-temporaries warnings pop up, as this means that +! the intrinsic call has not been properly simplified. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + ! Some explicitely shaped arrays and allocatable ones. + INTEGER :: a(2, 3), b(0:1, 4:6) + INTEGER, ALLOCATABLE :: x(:, :), y(:, :) + + ! Allocate to matching sizes and initialize. + ALLOCATE (x(-1:0, -3:-1), y(11:12, 3)) + a = 0 + b = 1 + x = 2 + y = 3 + + ! Run the checks. This should be simplified without array temporaries, + ! and additionally correct (of course). + + ! Shape of expressions known at compile-time. + IF (ANY (LBOUND (a + b) /= 1)) CALL abort () + IF (ANY (UBOUND (2 * b) /= (/ 2, 3 /))) CALL abort () + IF (ANY (SHAPE (- b) /= (/ 2, 3 /))) CALL abort () + IF (SIZE (a ** 2) /= 6) CALL abort + + ! Shape unknown at compile-time. + IF (ANY (LBOUND (x + y) /= 1)) CALL abort () + IF (SIZE (x ** 2) /= 6) CALL abort () + + ! Unfortunately, the array-version of UBOUND and SHAPE keep generating + ! temporary arrays for their results (not for the operation). Thus we + ! can not check SHAPE in this case and do UBOUND in the single-dimension + ! version. + IF (UBOUND (2 * y, 1) /= 2 .OR. UBOUND (2 * y, 2) /= 3) CALL abort () + !IF (ANY (SHAPE (- y) /= (/ 2, 3 /))) CALL abort () +END PROGRAM main