From patchwork Sat Mar 16 14:54:01 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 228218 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 50D752C00B7 for ; Sun, 17 Mar 2013 01:55:04 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1364050506; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=jXB5YLQ iL5Vf/HiRp9K4y8Pglfw=; b=EFEo+Okj0vGRDbY+n7ckWtoteNgvcTzcHHpJtIB 8GNKbJmFmZtBwygGuxEczEuMkZHawtG9JqUzORVnjXTHP7ei42+o1ViGd6CAgfTK iu/BrL8a5rTd1JEL2xIzqyDWoLH8B8bhlIuUXDz5JFI4B0uaHexeB/EhALp3Ktr9 IkLE= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=ew6/Bjdwdfmfei9TX3lBIrP2hHR8cdk5RSCm0O6eV9PMKHWsjJe9ihfoiVD2b8 LHGSM5+sOetmkQkOvzNlMUUClwa1HLBJbFot7MJ4XFZN4zQRI7MdGBIK1xqVU7o/ 8MZQXLd05eHzj6bXt94HWF3/sPev/foEGKjCnqcjG1Drw=; Received: (qmail 31834 invoked by alias); 16 Mar 2013 14:54:48 -0000 Received: (qmail 31811 invoked by uid 22791); 16 Mar 2013 14:54:45 -0000 X-SWARE-Spam-Status: No, hits=-3.2 required=5.0 tests=AWL, BAYES_00, KHOP_RCVD_UNTRUST, RCVD_IN_DNSWL_LOW, RCVD_IN_HOSTKARMA_NO, RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from cc-smtpout2.netcologne.de (HELO cc-smtpout2.netcologne.de) (89.1.8.212) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 16 Mar 2013 14:54:05 +0000 Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 0D5181298A; Sat, 16 Mar 2013 15:54:03 +0100 (CET) Received: from [192.168.0.107] (xdsl-87-79-197-82.netcologne.de [87.79.197.82]) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA id B6F7411DA6; Sat, 16 Mar 2013 15:54:01 +0100 (CET) Message-ID: <51448789.5020105@netcologne.de> Date: Sat, 16 Mar 2013 15:54:01 +0100 From: Thomas Koenig User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130307 Thunderbird/17.0.4 MIME-Version: 1.0 To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran, 4.9] Dependency and string length calculation improvements 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 Hello world, below is a patch which improves dependency checking for array assignments and calculation of string lengths. The new function gfc_dep_difference is used for both. This allows us to detect, for example, that the difference between the lower indices of a(n:m:2) = a(n+1:m+1:2) is one, thus making an array temporary unnecessary. I have tried to cover every code path through gfc_dep_difference in string_length_2.f90. dependency_40.f90 is just there to test the basic functionality. OK for trunk? Thomas 2013-03-16 Thomas Koenig PR fortran/45159 * gfortran.h (gfc_dep_difference): Add prototype. * dependency.c (discard_nops): New function. (gfc_dep_difference): New function. (check_section_vs_section): Use gfc_dep_difference to calculate the difference of starting indices. * trans-expr.c (gfc_conv_substring): Use gfc_dep_difference to calculate the length of substrings where possible. 2013-03-16 Thomas Koenig PR fortran/45159 * gfortran.dg/string_length_2.f90: New test. * gfortran.dg/dependency_40.f90: New test. Index: gfortran.h =================================================================== --- gfortran.h (Revision 196574) +++ gfortran.h (Arbeitskopie) @@ -2959,6 +2959,7 @@ gfc_namespace* gfc_build_block_ns (gfc_namespace * /* dependency.c */ int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool); int gfc_dep_compare_expr (gfc_expr *, gfc_expr *); +bool gfc_dep_difference (gfc_expr *, gfc_expr *, mpz_t *); /* check.c */ gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*); Index: dependency.c =================================================================== --- dependency.c (Revision 196574) +++ dependency.c (Arbeitskopie) @@ -500,7 +500,270 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) } } +/* Helper function to look through parens and unary plus. */ +static gfc_expr* +discard_nops (gfc_expr *e) +{ + + while (e && e->expr_type == EXPR_OP + && (e->value.op.op == INTRINSIC_UPLUS + || e->value.op.op == INTRINSIC_PARENTHESES)) + e = e->value.op.op1; + + return e; +} +/* Return the difference between two expressions. Integer expressions of + the form + + X + constant, X - constant and constant + X + + are handled. Return true on success, false on failure. result is assumed + to be uninitialized on entry, and will be initialized on success. +*/ + +bool +gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result) +{ + gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2; + + if (e1 == NULL || e2 == NULL) + return false; + + if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) + return false; + + e1 = discard_nops (e1); + e2 = discard_nops (e2); + + /* Inizialize tentatively, clear if we don't return anything. */ + mpz_init (*result); + + /* Case 1: c1 - c2 = c1 - c2, trivially. */ + + if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT) + { + mpz_sub (*result, e1->value.integer, e2->value.integer); + return true; + } + + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) + { + e1_op1 = discard_nops (e1->value.op.op1); + e1_op2 = discard_nops (e1->value.op.op2); + + /* Case 2: (X + c1) - X = c1. */ + if (e1_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2) == 0) + { + mpz_set (*result, e1_op2->value.integer); + return true; + } + + /* Case 3: (c1 + X) - X = c1. */ + if (e1_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2) == 0) + { + mpz_set (*result, e1_op1->value.integer); + return true; + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 4: X + c1 - (X + c2) = c1 - c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_sub (*result, e1_op2->value.integer, + e2_op2->value.integer); + return true; + } + /* Case 5: X + c1 - (c2 + X) = c1 - c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) + { + mpz_sub (*result, e1_op2->value.integer, + e2_op1->value.integer); + return true; + } + } + else if (e1_op1->expr_type == EXPR_CONSTANT) + { + /* Case 6: c1 + X - (X + c2) = c1 - c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op2->value.integer); + return true; + } + /* Case 7: c1 + X - (c2 + X) = c1 - c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op2) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op1->value.integer); + return true; + } + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 8: X + c1 - (X - c2) = c1 + c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op2->value.integer); + return true; + } + } + if (e1_op1->expr_type == EXPR_CONSTANT) + { + /* Case 9: c1 + X - (X - c2) = c1 + c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) + { + mpz_add (*result, e1_op1->value.integer, + e2_op2->value.integer); + return true; + } + } + } + } + + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) + { + e1_op1 = discard_nops (e1->value.op.op1); + e1_op2 = discard_nops (e1->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 10: (X - c1) - X = -c1 */ + + if (gfc_dep_compare_expr (e1_op1, e2) == 0) + { + mpz_neg (*result, e1_op2->value.integer); + return true; + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op2->value.integer); + mpz_neg (*result, *result); + return true; + } + + /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op1->value.integer); + mpz_neg (*result, *result); + return true; + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 13: (X - c1) - (X - c2) = c2 - c1. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_sub (*result, e2_op2->value.integer, + e1_op2->value.integer); + return true; + } + } + } + if (e1_op1->expr_type == EXPR_CONSTANT) + { + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */ + if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op1->value.integer); + return true; + } + } + + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 15: X - (X + c2) = -c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op1) == 0) + { + mpz_neg (*result, e2_op2->value.integer); + return true; + } + /* Case 16: X - (c2 + X) = -c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op2) == 0) + { + mpz_neg (*result, e2_op1->value.integer); + return true; + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 17: X - (X - c2) = c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op1) == 0) + { + mpz_set (*result, e2_op2->value.integer); + return true; + } + } + + if (gfc_dep_compare_expr(e1, e2) == 0) + { + /* Case 18: X - X = 0. */ + mpz_set_si (*result, 0); + return true; + } + + mpz_clear (*result); + return false; +} + /* Returns 1 if the two ranges are the same and 0 if they are not (or if the results are indeterminate). 'n' is the dimension to compare. */ @@ -1140,6 +1403,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc int r_dir; int stride_comparison; int start_comparison; + mpz_t tmp; /* If they are the same range, return without more ado. */ if (is_same_range (l_ar, r_ar, n)) @@ -1282,23 +1546,20 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \ && (a)->ts.type == BT_INTEGER) - if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start) - && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride)) + if (IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride) + && gfc_dep_difference (l_start, r_start, &tmp)) { - mpz_t gcd, tmp; + mpz_t gcd; int result; mpz_init (gcd); - mpz_init (tmp); - mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer); - mpz_sub (tmp, l_start->value.integer, r_start->value.integer); mpz_fdiv_r (tmp, tmp, gcd); result = mpz_cmp_si (tmp, 0L); mpz_clear (gcd); - mpz_clear (tmp); + mpz_clear (tmp); /* gfc_dep_difference returned true, so tmp was initialized. */ if (result != 0) return GFC_DEP_NODEP; Index: trans-expr.c =================================================================== --- trans-expr.c (Revision 196574) +++ trans-expr.c (Arbeitskopie) @@ -1437,6 +1437,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, in gfc_se start; gfc_se end; char *msg; + mpz_t length; type = gfc_get_character_type (kind, ref->u.ss.length); type = build_pointer_type (type); @@ -1520,10 +1521,19 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, in free (msg); } - /* If the start and end expressions are equal, the length is one. */ + /* Try to calculate the length from the start and end expressions. */ if (ref->u.ss.end - && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0) - tmp = build_int_cst (gfc_charlen_type_node, 1); + && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length)) + { + int i_len; + + i_len = mpz_get_si (length) + 1; + if (i_len < 0) + i_len = 0; + + tmp = build_int_cst (gfc_charlen_type_node, i_len); + mpz_clear (length); /* Was initialized by gfc_dep_difference. */ + } else { tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,