From patchwork Sat Mar 26 09:43:36 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 88458 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 248A61007D5 for ; Sat, 26 Mar 2011 20:43:51 +1100 (EST) Received: (qmail 13596 invoked by alias); 26 Mar 2011 09:43:46 -0000 Received: (qmail 13578 invoked by uid 22791); 26 Mar 2011 09:43:45 -0000 X-SWARE-Spam-Status: No, hits=-0.3 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_FC, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from cc-smtpout1.netcologne.de (HELO cc-smtpout1.netcologne.de) (89.1.8.211) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 26 Mar 2011 09:43:40 +0000 Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout1.netcologne.de (Postfix) with ESMTP id 7C184120F5; Sat, 26 Mar 2011 10:43:38 +0100 (CET) Received: from [192.168.0.197] (xdsl-78-35-151-58.netcologne.de [78.35.151.58]) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA id 6285811E81; Sat, 26 Mar 2011 10:43:37 +0100 (CET) Message-ID: <4D8DB548.7090803@netcologne.de> Date: Sat, 26 Mar 2011 10:43:36 +0100 From: Thomas Koenig User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.14) Gecko/20110221 SUSE/3.1.8 Thunderbird/3.1.8 MIME-Version: 1.0 To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, Fortran] Some more trim optimizatins 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, the following patch extends the trim optimization to variables like trim(a%x). Going for trim(a(1)) led to a very strange regression, so I took that out (for now). Regression-tested. OK for trunk? Thomas 2011-03-26 Thomas Koenig PR fortran/47065 * frontend-passes (optimize_trim): Also follow references, except when they are substring references or array references. 2011-03-26 Thomas Koenig PR fortran/47065 * gfortran.dg/trim_optimize_5.f90: New test. * gfortran.dg/trim_optimize_6.f90: New test. ! { dg-do run } ! { dg-options "-O -fdump-tree-original" } ! PR 47065 - replace trim with substring expressions even with references. program main use foo implicit none type t character(len=2) :: x end type t type(t) :: a character(len=3) :: b character(len=10) :: line a%x = 'a' write(unit=line,fmt='(A,A)') trim(a%x),"X" if (line /= 'aX ') call abort b = 'ab' write (unit=line,fmt='(A,A)') trim(b),"Y" if (line /= 'abY ') call abort end program main ! { dg-final { scan-tree-dump-times "string_len_trim" 2 "original" } } ! { dg-final { cleanup-tree-dump "original" } } ! { dg-do run } ! PR 47065 - make sure that impure functions are not evaluated twice when ! replacing calls to trim with expression(1:len_trim) module foo implicit none contains function f() integer :: f integer :: s=0 s = s + 1 f = s end function f end module foo program main use foo implicit none character(len=10) :: line character(len=4) :: b(2) b(1) = 'a' b(2) = 'bc' write(unit=line,fmt='(A,A)') trim(b(f())), "X" if (line /= "aX ") call abort if (f() .ne. 2) call abort end program main Index: frontend-passes.c =================================================================== --- frontend-passes.c (Revision 171207) +++ frontend-passes.c (Arbeitskopie) @@ -664,6 +664,7 @@ gfc_ref *ref; gfc_expr *fcn; gfc_actual_arglist *actual_arglist, *next; + gfc_ref **rr = NULL; /* Don't do this optimization within an argument list, because otherwise aliasing issues may occur. */ @@ -681,46 +682,54 @@ if (a->expr_type != EXPR_VARIABLE) return false; + /* Follow all references to find the correct place to put the newly + created reference. FIXME: Also handle substring references and + array references. Array references cause strange regressions at + the moment. */ + if (a->ref) { - /* FIXME - also handle substring references, by modifying the - reference itself. Make sure not to evaluate functions in - the references twice. */ - return false; + for (rr = &(a->ref); *rr; rr = &((*rr)->next)) + { + if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY) + return false; + } } - else - { - strip_function_call (e); - /* Create the reference. */ + strip_function_call (e); - ref = gfc_get_ref (); - ref->type = REF_SUBSTRING; + if (e->ref == NULL) + rr = &(e->ref); - /* Set the start of the reference. */ + /* Create the reference. */ - ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + ref = gfc_get_ref (); + ref->type = REF_SUBSTRING; - /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */ + /* Set the start of the reference. */ - fcn = gfc_get_expr (); - fcn->expr_type = EXPR_FUNCTION; - fcn->value.function.isym = - gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); - actual_arglist = gfc_get_actual_arglist (); - actual_arglist->expr = gfc_copy_expr (e); - next = gfc_get_actual_arglist (); - next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, - gfc_default_integer_kind); - actual_arglist->next = next; - fcn->value.function.actual = actual_arglist; + ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - /* Set the end of the reference to the call to len_trim. */ + /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */ - ref->u.ss.end = fcn; - e->ref = ref; - return true; - } + fcn = gfc_get_expr (); + fcn->expr_type = EXPR_FUNCTION; + fcn->value.function.isym = + gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); + actual_arglist = gfc_get_actual_arglist (); + actual_arglist->expr = gfc_copy_expr (e); + next = gfc_get_actual_arglist (); + next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, + gfc_default_integer_kind); + actual_arglist->next = next; + fcn->value.function.actual = actual_arglist; + + /* Set the end of the reference to the call to len_trim. */ + + ref->u.ss.end = fcn; + gcc_assert (*rr == NULL); + *rr = ref; + return true; } #define WALK_SUBEXPR(NODE) \