From patchwork Fri Apr 13 13:57:58 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 152313 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 0BA98B700A for ; Fri, 13 Apr 2012 23:58:26 +1000 (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=1334930307; 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=IhPjFmG xeXS/h+wd1UMh65veIjY=; b=Mb/q06xKv3p0beBy78Ml8K0gATtf9z3FxwdS6rW P3N08P8FXVzCLIWui5GpnGyYYCyzhUaBX7x2FIOx/wARcLwNWXGeqLT3Z+iRz9z/ hQURoIp087iyvDNRlI9gPGJsl4NBeRgft7ba/vbmmXoBzU54ovC6/rnIytdcJW/v pvUA= 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=m7aILmyt005JxbQWK0qxo4y+a89jIOEpwYgcBStxqABEWwQaXzcRw6QX0ujWMc k3sDJLZbfufpGNYk0+wIzg+eluFg3gv+3LYgpvXymZOb8cR5DwEn0m/oXL67CWUM 2zVhNpNRnsN47ISTwPbYNI8u3oeG28RlYWYTgJcPdPITg=; Received: (qmail 11366 invoked by alias); 13 Apr 2012 13:58:18 -0000 Received: (qmail 11348 invoked by uid 22791); 13 Apr 2012 13:58:17 -0000 X-SWARE-Spam-Status: No, hits=-0.7 required=5.0 tests=AWL, BAYES_00, KAM_STOCKGEN, KHOP_RCVD_UNTRUST, RCVD_IN_DNSWL_LOW, RCVD_IN_HOSTKARMA_NO, TW_FC, T_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; Fri, 13 Apr 2012 13:58:02 +0000 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 6AA9C12746; Fri, 13 Apr 2012 15:58:00 +0200 (CEST) Received: from [192.168.0.109] (xdsl-78-35-142-139.netcologne.de [78.35.142.139]) by cc-smtpin1.netcologne.de (Postfix) with ESMTPSA id 365E011D89; Fri, 13 Apr 2012 15:57:59 +0200 (CEST) Message-ID: <4F8830E6.8060804@netcologne.de> Date: Fri, 13 Apr 2012 15:57:58 +0200 From: Thomas Koenig User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.17) Gecko/20110414 SUSE/3.1.10 Thunderbird/3.1.10 MIME-Version: 1.0 To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran] PR fortran/52537 Optimize string comparisons against empty strings 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, this patch replaces a != '' with len_trim(a) != 0, to speed up the comparison. It also introduces a bit of cleanup in frontend-passes.c. Regression-tested. OK for trunk? Thomas 2012-04-13 Thomas Koenig PR fortran/52537 * frontend-passes.c (optimize_op): Change old-style comparison operators to new-style, simplify switch as a result. (empty_string): New function. (get_len_trim_call): New function. (optimize_comparison): If comparing to an empty string, use comparison of len_trim to zero. Use new-style comparison operators only. (optimize_trim): Use get_len_trim_call. 2012-04-13 Thomas Koenig PR fortran/52537 * gfortran.dg/string_compare_4.f90: New test. ! { dg-do compile } ! { dg-options "-ffrontend-optimize -fdump-fortran-original" } ! PR fortran/52537 - optimize comparisons with empty strings program main implicit none character(len=10) :: a character(len=30) :: line line = 'x' read (unit=line,fmt='(A)') a if (trim(a) == '') print *,"empty" call foo(a) if (trim(a) == ' ') print *,"empty" contains subroutine foo(b) character(*) :: b if (b /= ' ') print *,"full" end subroutine foo end program main ! { dg-final { scan-tree-dump-times "_gfortran_string_len_trim" 3 "original" } } ! { dg-final { cleanup-tree-dump "original" } } Index: frontend-passes.c =================================================================== --- frontend-passes.c (Revision 186213) +++ frontend-passes.c (Arbeitskopie) @@ -796,20 +796,45 @@ optimize_op (gfc_expr *e) { gfc_intrinsic_op op = e->value.op.op; + /* Only use new-style comparisions. */ + switch(op) + { + case INTRINSIC_EQ_OS: + op = INTRINSIC_EQ; + break; + + case INTRINSIC_GE_OS: + op = INTRINSIC_GE; + break; + + case INTRINSIC_LE_OS: + op = INTRINSIC_LE; + break; + + case INTRINSIC_NE_OS: + op = INTRINSIC_NE; + break; + + case INTRINSIC_GT_OS: + op = INTRINSIC_GT; + break; + + case INTRINSIC_LT_OS: + op = INTRINSIC_LT; + break; + + default: + break; + } + switch (op) { case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: case INTRINSIC_GE: - case INTRINSIC_GE_OS: case INTRINSIC_LE: - case INTRINSIC_LE_OS: case INTRINSIC_NE: - case INTRINSIC_NE_OS: case INTRINSIC_GT: - case INTRINSIC_GT_OS: case INTRINSIC_LT: - case INTRINSIC_LT_OS: return optimize_comparison (e, op); default: @@ -819,6 +844,61 @@ optimize_op (gfc_expr *e) return false; } +/* Return true if a constant string contains spaces only. */ + +static bool +empty_string (gfc_expr *e) +{ + int i; + + if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) + return false; + + for (i=0; ivalue.character.length; i++) + { + if (e->value.character.string[i] != ' ') + return false; + } + + return true; +} + +/* Insert a call to the intrinsic len_trim. Use a different name for + the symbol tree so we don't run into trouble when the user has + renamed len_trim for some reason. */ + +static gfc_expr* +get_len_trim_call (gfc_expr *str, int kind) +{ + gfc_expr *fcn; + gfc_actual_arglist *actual_arglist, *next; + + 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 = str; + next = gfc_get_actual_arglist (); + next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind); + actual_arglist->next = next; + + fcn->value.function.actual = actual_arglist; + fcn->where = str->where; + fcn->ts.type = BT_INTEGER; + fcn->ts.kind = gfc_charlen_int_kind; + + gfc_get_sym_tree("__internal_len_trim", current_ns, &fcn->symtree, false); + fcn->symtree->n.sym->ts = fcn->ts; + fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; + fcn->symtree->n.sym->attr.function = 1; + fcn->symtree->n.sym->attr.elemental = 1; + fcn->symtree->n.sym->attr.referenced = 1; + fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; + gfc_commit_symbol (fcn->symtree->n.sym); + + return fcn; +} + /* Optimize expressions for equality. */ static bool @@ -862,6 +942,46 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op if (e->rank > 0) return change; + /* Replace a == '' with len_trim(a) == 0 and a /= '' with + len_trim(a) != 0 */ + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && (op == INTRINSIC_EQ || op == INTRINSIC_NE)) + { + + bool empty_op1, empty_op2; + empty_op1 = empty_string(op1); + empty_op2 = empty_string(op2); + + if (empty_op1 || empty_op2) + { + gfc_expr *fcn; + gfc_expr *zero; + gfc_expr *str; + + /* This can only happen when an error for comparing + characters of different kinds has already been issued. */ + if (empty_op1 && empty_op2) + return false; + + zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0); + str = empty_op1 ? op2 : op1; + + fcn = get_len_trim_call (str, gfc_charlen_int_kind); + + + if (empty_op1) + gfc_free_expr (op1); + else + gfc_free_expr (op2); + + op1 = fcn; + op2 = zero; + e->value.op.op1 = fcn; + e->value.op.op2 = zero; + } + } + + /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */ if (flag_finite_math_only @@ -935,32 +1055,26 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op switch (op) { case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: result = eq == 0; break; case INTRINSIC_GE: - case INTRINSIC_GE_OS: result = eq >= 0; break; case INTRINSIC_LE: - case INTRINSIC_LE_OS: result = eq <= 0; break; case INTRINSIC_NE: - case INTRINSIC_NE_OS: result = eq != 0; break; case INTRINSIC_GT: - case INTRINSIC_GT_OS: result = eq > 0; break; case INTRINSIC_LT: - case INTRINSIC_LT_OS: result = eq < 0; break; @@ -992,7 +1106,6 @@ optimize_trim (gfc_expr *e) gfc_expr *a; 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 @@ -1041,17 +1154,7 @@ optimize_trim (gfc_expr *e) /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */ - 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; + fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind); /* Set the end of the reference to the call to len_trim. */