diff mbox

Optimize SELECT CASE for character length 1

Message ID 20100715134355.GP20208@tyan-ft48-01.lab.bos.redhat.com
State New
Headers show

Commit Message

Jakub Jelinek July 15, 2010, 1:43 p.m. UTC 
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  <jakub@redhat.com>

	* 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

Comments

Tobias Burnus July 15, 2010, 1:54 p.m. UTC | #1 
On Thu, Jul 15, 2010 at 03:43:55PM +0200, Jakub Jelinek wrote:
> 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?

Yes. Thanks for the patch!

Tobias
 
> 2010-07-15  Jakub Jelinek  <jakub@redhat.com>
> 
> 	* 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.
diff mbox

Patch

--- 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" } }