From patchwork Wed Jul 14 22:58:02 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: Optimize SELECT CASE for character length 1 Date: Wed, 14 Jul 2010 12:58:02 -0000 From: Jakub Jelinek X-Patchwork-Id: 58938 Message-Id: <20100714225802.GL20208@tyan-ft48-01.lab.bos.redhat.com> To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Hi! For character length 1, we can easily avoid calling the library function, instead a normal SWITCH_EXPR can be emitted. Bootstrapped/regtested on x86_64-linux and i686-linux. Ok for trunk? 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. * trans-stmt.c (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-14 11:34:20.000000000 +0200 +++ gcc/fortran/trans.h 2010-07-14 17:37:48.000000000 +0200 @@ -299,6 +299,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-14 12:20:34.000000000 +0200 +++ gcc/fortran/trans-expr.c 2010-07-14 17:14:03.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/trans-stmt.c.jj 2010-07-13 15:56:30.000000000 +0200 +++ gcc/fortran/trans-stmt.c 2010-07-14 22:21:29.000000000 +0200 @@ -1610,7 +1610,7 @@ 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; @@ -1623,6 +1623,141 @@ gfc_trans_character_select (gfc_code *co 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) + { + if (d->low->expr_type != EXPR_CONSTANT + || d->low->ts.type != BT_CHARACTER) + break; + 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) + break; + } + } + if (d->high) + { + if (d->high->expr_type != EXPR_CONSTANT + || d->high->ts.type != BT_CHARACTER) + break; + 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) + { + 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; else if (code->expr1->ts.kind == 4) @@ -1661,20 +1796,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) @@ -1694,7 +1819,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; @@ -1751,11 +1876,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) @@ -1765,11 +1885,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); --- gcc/testsuite/gfortran.dg/select_char_2.f90.jj 2010-07-14 22:01:24.000000000 +0200 +++ gcc/testsuite/gfortran.dg/select_char_2.f90 2010-07-14 22:00:23.000000000 +0200 @@ -0,0 +1,23 @@ + 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 +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 +end