From patchwork Thu Jul 15 13:43:55 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jakub Jelinek X-Patchwork-Id: 58984 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 3D4BEB6EDF for ; Thu, 15 Jul 2010 23:42:50 +1000 (EST) Received: (qmail 31462 invoked by alias); 15 Jul 2010 13:42:42 -0000 Received: (qmail 31132 invoked by uid 22791); 15 Jul 2010 13:42:36 -0000 X-SWARE-Spam-Status: No, hits=-6.0 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_HI, SPF_HELO_PASS, TW_BG, TW_FN, TW_TM, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mx1.redhat.com (HELO mx1.redhat.com) (209.132.183.28) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 15 Jul 2010 13:42:13 +0000 Received: from int-mx05.intmail.prod.int.phx2.redhat.com (int-mx05.intmail.prod.int.phx2.redhat.com [10.5.11.18]) by mx1.redhat.com (8.13.8/8.13.8) with ESMTP id o6FDgBaI006110 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES256-SHA bits=256 verify=OK); Thu, 15 Jul 2010 09:42:11 -0400 Received: from tyan-ft48-01.lab.bos.redhat.com (tyan-ft48-01.lab.bos.redhat.com [10.16.42.4]) by int-mx05.intmail.prod.int.phx2.redhat.com (8.13.8/8.13.8) with ESMTP id o6FDgASE024441 (version=TLSv1/SSLv3 cipher=DHE-RSA-AES256-SHA bits=256 verify=NO); Thu, 15 Jul 2010 09:42:11 -0400 Received: from tyan-ft48-01.lab.bos.redhat.com (tyan-ft48-01.lab.bos.redhat.com [127.0.0.1]) by tyan-ft48-01.lab.bos.redhat.com (8.14.4/8.14.4) with ESMTP id o6FDhuEi008972; Thu, 15 Jul 2010 15:43:56 +0200 Received: (from jakub@localhost) by tyan-ft48-01.lab.bos.redhat.com (8.14.4/8.14.4/Submit) id o6FDhtdB008971; Thu, 15 Jul 2010 15:43:55 +0200 Date: Thu, 15 Jul 2010 15:43:55 +0200 From: Jakub Jelinek To: Tobias Burnus Cc: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: Re: [PATCH] Optimize SELECT CASE for character length 1 Message-ID: <20100715134355.GP20208@tyan-ft48-01.lab.bos.redhat.com> Reply-To: Jakub Jelinek References: <20100715100219.GA8634@physik.fu-berlin.de> MIME-Version: 1.0 Content-Disposition: inline In-Reply-To: <20100715100219.GA8634@physik.fu-berlin.de> User-Agent: Mutt/1.5.20 (2009-12-10) X-IsSubscribed: yes 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 On Thu, Jul 15, 2010 at 12:02:19PM +0200, Tobias Burnus wrote: > Constant means something which the front end (simplify expr) can > reduce to a simple number or string literal. (F2003 called this > initialization expression.) In order to make this possible, only > intrinsic functions are allowed, cf. "7.1.12 Constant expression"; > thus in trans*.c this should be a simple constant string (literal). Ok. > > True, in this case yes. I was thinking about the general case ("ab":"cd") > > something case ("ce":) something else > > which, while solvable, would be harder. For the above the question is just > > if no problems will be with some potentially unreachable code. > > I am not sure about your last sentence, but one could actually warn with > -Wunreachable-code - something which is not possible with version using the > library call. > > (On the other hand, the number of codes which actually uses length > 1 case > selectors is rather small; thus, I don't know whether one really needs to > optimize this case.) Ok, I've added handling of this case (first char the same between hi and low, second chars both smaller or bigger than ' '. I don't think it is worth wasting more time on that though, it will be very rare. > > It was meant to be a run test, forgot dg-do there apparently. > > For a tree-dump test, I guess we'd need another testcase with dg-do compile. > > Why? -fdump-tree-original plus something along the following lines should be > possible and sufficient, shouldn't it? I was thinking about assembly scan, which doesn't work with dg-do run, you've right -fdump-tree-original scan works with runtime testcases just fine. Here is an updated, so far untested, patch. I've noticed that select_struct should be GTY(()) marked to avoid it being eaten by GC, the other statics are just fields of that struct, so they are accessible from select_struct by GC. Ok for trunk if this passes bootstrap/regtest? 2010-07-15 Jakub Jelinek * trans.h (gfc_string_to_single_character): New prototype. * trans-expr.c (string_to_single_character): Renamed to ... (gfc_string_to_single_character): ... this. No longer static. (gfc_conv_scalar_char_value, gfc_build_compare_string, gfc_trans_string_copy): Adjust callers. * config-lang.in (gtfiles): Add fortran/trans-stmt.c. * trans-stmt.c: Include ggc.h and gt-fortran-trans-stmt.h. (select_struct): Move to toplevel, add GTY(()). (gfc_trans_character_select): Optimize SELECT CASE with character length 1. * gfortran.dg/select_char_2.f90: New test. Jakub --- gcc/fortran/trans.h.jj 2010-07-15 14:36:13.000000000 +0200 +++ gcc/fortran/trans.h 2010-07-15 14:40:27.000000000 +0200 @@ -322,6 +322,7 @@ void gfc_conv_expr_type (gfc_se * se, gf /* trans-expr.c */ void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr); +tree gfc_string_to_single_character (tree len, tree str, int kind); /* Find the decl containing the auxiliary variables for assigned variables. */ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); --- gcc/fortran/trans-expr.c.jj 2010-07-15 14:36:13.000000000 +0200 +++ gcc/fortran/trans-expr.c 2010-07-15 14:40:27.000000000 +0200 @@ -1389,8 +1389,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr /* If a string's length is one, we convert it to a single character. */ -static tree -string_to_single_character (tree len, tree str, int kind) +tree +gfc_string_to_single_character (tree len, tree str, int kind) { gcc_assert (POINTER_TYPE_P (TREE_TYPE (str))); @@ -1475,7 +1475,7 @@ gfc_conv_scalar_char_value (gfc_symbol * { if ((*expr)->ref == NULL) { - se->expr = string_to_single_character + se->expr = gfc_string_to_single_character (build_int_cst (integer_type_node, 1), gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), gfc_get_symbol_decl @@ -1485,7 +1485,7 @@ gfc_conv_scalar_char_value (gfc_symbol * else { gfc_conv_variable (se, *expr); - se->expr = string_to_single_character + se->expr = gfc_string_to_single_character (build_int_cst (integer_type_node, 1), gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), se->expr), @@ -1544,8 +1544,8 @@ gfc_build_compare_string (tree len1, tre gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); - sc1 = string_to_single_character (len1, str1, kind); - sc2 = string_to_single_character (len2, str2, kind); + sc1 = gfc_string_to_single_character (len1, str1, kind); + sc2 = gfc_string_to_single_character (len2, str2, kind); if (sc1 != NULL_TREE && sc2 != NULL_TREE) { @@ -3618,7 +3618,7 @@ gfc_trans_string_copy (stmtblock_t * blo if (slength != NULL_TREE) { slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); - ssc = string_to_single_character (slen, src, skind); + ssc = gfc_string_to_single_character (slen, src, skind); } else { @@ -3629,7 +3629,7 @@ gfc_trans_string_copy (stmtblock_t * blo if (dlength != NULL_TREE) { dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); - dsc = string_to_single_character (dlen, dest, dkind); + dsc = gfc_string_to_single_character (dlen, dest, dkind); } else { --- gcc/fortran/config-lang.in.jj 2009-05-04 16:46:11.000000000 +0200 +++ gcc/fortran/config-lang.in 2010-07-15 15:05:15.000000000 +0200 @@ -29,5 +29,5 @@ compilers="f951\$(exeext)" target_libs=target-libgfortran -gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h" +gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-stmt.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h" --- gcc/fortran/trans-stmt.c.jj 2010-07-15 14:36:13.000000000 +0200 +++ gcc/fortran/trans-stmt.c 2010-07-15 15:30:08.000000000 +0200 @@ -34,6 +34,7 @@ along with GCC; see the file COPYING3. #include "trans-const.h" #include "arith.h" #include "dependency.h" +#include "ggc.h" typedef struct iter_info { @@ -1594,6 +1595,10 @@ gfc_trans_logical_select (gfc_code * cod } +/* The jump table types are stored in static variables to avoid + constructing them from scratch every single time. */ +static GTY(()) tree select_struct[2]; + /* Translate the SELECT CASE construct for CHARACTER case expressions. Instead of generating compares and jumps, it is far simpler to generate a data structure describing the cases in order and call a @@ -1610,18 +1615,171 @@ gfc_trans_character_select (gfc_code *co stmtblock_t block, body; gfc_case *cp, *d; gfc_code *c; - gfc_se se; + gfc_se se, expr1se; int n, k; VEC(constructor_elt,gc) *inits = NULL; + tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); + /* The jump table types are stored in static variables to avoid constructing them from scratch every single time. */ - static tree select_struct[2]; static tree ss_string1[2], ss_string1_len[2]; static tree ss_string2[2], ss_string2_len[2]; static tree ss_target[2]; - tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); + cp = code->block->ext.case_list; + while (cp->left != NULL) + cp = cp->left; + + /* Generate the body */ + gfc_start_block (&block); + gfc_init_se (&expr1se, NULL); + gfc_conv_expr_reference (&expr1se, code->expr1); + + gfc_add_block_to_block (&block, &expr1se.pre); + + end_label = gfc_build_label_decl (NULL_TREE); + + gfc_init_block (&body); + + /* Attempt to optimize length 1 selects. */ + if (expr1se.string_length == integer_one_node) + { + for (d = cp; d; d = d->right) + { + int i; + if (d->low) + { + gcc_assert (d->low->expr_type == EXPR_CONSTANT + && d->low->ts.type == BT_CHARACTER); + if (d->low->value.character.length > 1) + { + for (i = 1; i < d->low->value.character.length; i++) + if (d->low->value.character.string[i] != ' ') + break; + if (i != d->low->value.character.length) + { + if (optimize && d->high && i == 1) + { + gcc_assert (d->high->expr_type == EXPR_CONSTANT + && d->high->ts.type == BT_CHARACTER); + if (d->high->value.character.length > 1 + && (d->low->value.character.string[0] + == d->high->value.character.string[0]) + && d->high->value.character.string[1] != ' ' + && ((d->low->value.character.string[1] < ' ') + == (d->high->value.character.string[1] + < ' '))) + continue; + } + break; + } + } + } + if (d->high) + { + gcc_assert (d->high->expr_type == EXPR_CONSTANT + && d->high->ts.type == BT_CHARACTER); + if (d->high->value.character.length > 1) + { + for (i = 1; i < d->high->value.character.length; i++) + if (d->high->value.character.string[i] != ' ') + break; + if (i != d->high->value.character.length) + break; + } + } + } + if (d == NULL) + { + tree ctype = gfc_get_char_type (code->expr1->ts.kind); + + for (c = code->block; c; c = c->block) + { + for (cp = c->ext.case_list; cp; cp = cp->next) + { + tree low, high; + tree label; + gfc_char_t r; + + /* Assume it's the default case. */ + low = high = NULL_TREE; + + if (cp->low) + { + /* CASE ('ab') or CASE ('ab':'az') will never match + any length 1 character. */ + if (cp->low->value.character.length > 1 + && cp->low->value.character.string[1] != ' ') + continue; + + if (cp->low->value.character.length > 0) + r = cp->low->value.character.string[0]; + else + r = ' '; + low = build_int_cst (ctype, r); + + /* If there's only a lower bound, set the high bound + to the maximum value of the case expression. */ + if (!cp->high) + high = TYPE_MAX_VALUE (ctype); + } + + if (cp->high) + { + if (!cp->low + || (cp->low->value.character.string[0] + != cp->high->value.character.string[0])) + { + if (cp->high->value.character.length > 0) + r = cp->high->value.character.string[0]; + else + r = ' '; + high = build_int_cst (ctype, r); + } + + /* Unbounded case. */ + if (!cp->low) + low = TYPE_MIN_VALUE (ctype); + } + + /* Build a label. */ + label = gfc_build_label_decl (NULL_TREE); + + /* Add this case label. + Add parameter 'label', make it match GCC backend. */ + tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, + low, high, label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Add the statements for this case. */ + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + /* Break to the end of the construct. */ + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_string_to_single_character (expr1se.string_length, + expr1se.expr, + code->expr1->ts.kind); + case_num = gfc_create_var (ctype, "case_num"); + gfc_add_modify (&block, case_num, tmp); + + gfc_add_block_to_block (&block, &expr1se.post); + + tmp = gfc_finish_block (&body); + tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); + } + } if (code->expr1->ts.kind == 1) k = 0; @@ -1661,20 +1819,10 @@ gfc_trans_character_select (gfc_code *co gfc_finish_type (select_struct[k]); } - cp = code->block->ext.case_list; - while (cp->left != NULL) - cp = cp->left; - n = 0; for (d = cp; d; d = d->right) d->n = n++; - end_label = gfc_build_label_decl (NULL_TREE); - - /* Generate the body */ - gfc_start_block (&block); - gfc_init_block (&body); - for (c = code->block; c; c = c->block) { for (d = c->ext.case_list; d; d = d->next) @@ -1695,7 +1843,7 @@ gfc_trans_character_select (gfc_code *co } /* Generate the structure describing the branches */ - for(d = cp; d; d = d->right) + for (d = cp; d; d = d->right) { VEC(constructor_elt,gc) *node = NULL; @@ -1752,11 +1900,6 @@ gfc_trans_character_select (gfc_code *co /* Build the library call */ init = gfc_build_addr_expr (pvoid_type_node, init); - gfc_init_se (&se, NULL); - gfc_conv_expr_reference (&se, code->expr1); - - gfc_add_block_to_block (&block, &se.pre); - if (code->expr1->ts.kind == 1) fndecl = gfor_fndecl_select_string; else if (code->expr1->ts.kind == 4) @@ -1766,11 +1909,11 @@ gfc_trans_character_select (gfc_code *co tmp = build_call_expr_loc (input_location, fndecl, 4, init, build_int_cst (NULL_TREE, n), - se.expr, se.string_length); + expr1se.expr, expr1se.string_length); case_num = gfc_create_var (integer_type_node, "case_num"); gfc_add_modify (&block, case_num, tmp); - gfc_add_block_to_block (&block, &se.post); + gfc_add_block_to_block (&block, &expr1se.post); tmp = gfc_finish_block (&body); tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE); @@ -4494,3 +4637,4 @@ gfc_trans_deallocate (gfc_code *code) return gfc_finish_block (&block); } +#include "gt-fortran-trans-stmt.h" --- gcc/testsuite/gfortran.dg/select_char_2.f90.jj 2010-07-15 14:40:27.000000000 +0200 +++ gcc/testsuite/gfortran.dg/select_char_2.f90 2010-07-15 15:26:44.000000000 +0200 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } + + if (foo ('E') .ne. 1) call abort + if (foo ('e') .ne. 1) call abort + if (foo ('f') .ne. 2) call abort + if (foo ('g') .ne. 2) call abort + if (foo ('h') .ne. 2) call abort + if (foo ('Q') .ne. 3) call abort + if (foo (' ') .ne. 4) call abort + if (bar ('e') .ne. 1) call abort + if (bar ('f') .ne. 3) call abort +contains + function foo (c) + character :: c + integer :: foo + select case (c) + case ('E','e') + foo = 1 + case ('f':'h ') + foo = 2 + case default + foo = 3 + case ('') + foo = 4 + end select + end function + function bar (c) + character :: c + integer :: bar + select case (c) + case ('ea':'ez') + bar = 2 + case ('e') + bar = 1 + case default + bar = 3 + case ('fd') + bar = 4 + end select + end function +end + +! { dg-final { scan-tree-dump-not "_gfortran_select_string" "original" } } +! { dg-final { cleanup-tree-dump "original" } }