Re: [Gfortran, Patch] PR12456 - Optimize single character.

[Feng Wang <wf_cs at yahoo dot com>]

This is the revised path. Bootstrap and regtested on i686-pc-linux-gnu.

OK for trunk and gcc 4.1?

fortran ChangeLog entry:
2006-01-07  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/12456
	* trans-expr.c (gfc_to_single_character): New function that converts
	string to single character if its length is 1.
	(gfc_build_compare_string):New function that compare string and handle
	single character specially.
	(gfc_conv_expr_op): Use gfc_build_compare_string.
	(gfc_trans_string_copy): Use gfc_to_single_character.
	* trans-intrinsic.c (gfc_conv_intrinsic_strcmp): Use
	gfc_build_compare_string.
	* trans.h (gfc_build_compare_string): Add prototype.

testsuite ChangeLog entry:
2006-01-07  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/12456
	* gfortran.dg/pr12456.f90: New test.


--- Feng Wang <wf_cs@yahoo.com> wrote:

> --- Andrew Pinski <pinskia@physics.uc.edu> wrote:
> > 
> > On Jan 3, 2006, at 11:40 PM, Feng Wang wrote:
> > 


Best Regards,
Feng Wang

--
Creative Compiler Research Group,
National University of Defense Technology, China.


	

	
		
___________________________________________________________ 
雅虎1G免费邮箱百分百防垃圾信 
http://cn.mail.yahoo.com

! { dg-do run }
! { dg-options "-fdump-tree-original" }
! PR12456 - Optimize string(k:k) as single character.

Program pr12456
character a
character b
character (len=5) :: c
integer i

b = 'a'
a = b
if (a .ne. 'a') call abort()
if (a .ne. b) call abort()
c (3:3) = 'a'
if (c (3:3) .ne. b) call abort ()
if (c (3:3) .ne. 'a') call abort ()
if (LGT (a, c (3:3))) call abort ()
if (LGT (a, 'a')) call abort ()

i = 3
c (i:i) = 'a'
if (c (i:i) .ne. b) call abort ()
if (c (i:i) .ne. 'a') call abort ()
if (LGT (a, c (i:i))) call abort ()

if (a .gt. char (255)) call abort ()
end

! There should not be _gfortran_compare_string and _gfortran_copy_string in
! the dumped file.

! { dg-final { scan-tree-dump-times "_gfortran_compare_string" 0 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_copy_string" 0 "original" } }

! { dg-final { cleanup-tree-dump "original" } }

Index: trans.h
===================================================================
--- trans.h	(revision 109308)
+++ trans.h	(working copy)
@@ -268,6 +268,9 @@ void gfc_make_safe_expr (gfc_se * se);
 /* Makes sure se is suitable for passing as a function string parameter.  */
 void gfc_conv_string_parameter (gfc_se * se);
 
+/* Compare two strings.  */
+tree gfc_build_compare_string (tree, tree, tree, tree);
+
 /* Add an item to the end of TREE_LIST.  */
 tree gfc_chainon_list (tree, tree);
 
Index: trans-intrinsic.c
===================================================================
--- trans-intrinsic.c	(revision 109308)
+++ trans-intrinsic.c	(working copy)
@@ -2267,13 +2267,17 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, 
 {
   tree type;
   tree args;
+  tree arg2;
 
   args = gfc_conv_intrinsic_function_args (se, expr);
-  /* Build a call for the comparison.  */
-  se->expr = build_function_call_expr (gfor_fndecl_compare_string, args);
+  arg2 = TREE_CHAIN (TREE_CHAIN (args));
+
+  se->expr = gfc_build_compare_string (TREE_VALUE (args),
+		TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
+		TREE_VALUE (TREE_CHAIN (arg2)));
 
   type = gfc_typenode_for_spec (&expr->ts);
-  se->expr = build2 (op, type, se->expr,
+  se->expr = fold_build2 (op, type, se->expr,
 		     build_int_cst (TREE_TYPE (se->expr), 0));
 }
 
Index: trans-expr.c
===================================================================
--- trans-expr.c	(revision 109308)
+++ trans-expr.c	(working copy)
@@ -901,7 +901,6 @@ gfc_conv_concat_op (gfc_se * se, gfc_exp
   se->string_length = len;
 }
 
-
 /* Translates an op expression. Common (binary) cases are handled by this
    function, others are passed on. Recursion is used in either case.
    We use the fact that (op1.ts == op2.ts) (except for the power
@@ -1043,23 +1042,15 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr 
   gfc_conv_expr (&rse, expr->value.op.op2);
   gfc_add_block_to_block (&se->pre, &rse.pre);
 
-  /* For string comparisons we generate a library call, and compare the return
-     value with 0.  */
   if (checkstring)
     {
       gfc_conv_string_parameter (&lse);
       gfc_conv_string_parameter (&rse);
-      tmp = NULL_TREE;
-      tmp = gfc_chainon_list (tmp, lse.string_length);
-      tmp = gfc_chainon_list (tmp, lse.expr);
-      tmp = gfc_chainon_list (tmp, rse.string_length);
-      tmp = gfc_chainon_list (tmp, rse.expr);
-
-      /* Build a call for the comparison.  */
-      lse.expr = build_function_call_expr (gfor_fndecl_compare_string, tmp);
-      gfc_add_block_to_block (&lse.post, &rse.post);
 
+      lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
+					   rse.string_length, rse.expr);
       rse.expr = integer_zero_node;
+      gfc_add_block_to_block (&lse.post, &rse.post);
     }
 
   type = gfc_typenode_for_spec (&expr->ts);
@@ -1078,6 +1069,63 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr 
   gfc_add_block_to_block (&se->post, &lse.post);
 }
 
+/* If a string's length is one, we convert it to a single character.  */
+
+static tree
+gfc_to_single_character (tree len, tree str)
+{
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
+
+  if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
+    && TREE_INT_CST_HIGH (len) == 0)
+    {
+      str = fold_convert (pchar_type_node, str);
+      return build_fold_indirect_ref (str);
+    }
+
+  return NULL_TREE;
+}
+
+/*  Compare two strings. If they are all single characters, the result is the
+    subtraction of them. Otherwise, we build a library call.  */
+
+tree
+gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
+{
+  tree sc1;
+  tree sc2;
+  tree type;
+  tree tmp;
+
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
+  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
+
+  type = gfc_get_int_type (gfc_default_integer_kind);
+
+  sc1 = gfc_to_single_character (len1, str1);
+  sc2 = gfc_to_single_character (len2, str2);
+
+  /* Deal with single character specially.  */
+  if (sc1 != NULL_TREE && sc2 != NULL_TREE)
+    {
+      sc1 = fold_convert (type, sc1);
+      sc2 = fold_convert (type, sc2);
+      tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
+    }
+   else
+    {
+      tmp = NULL_TREE;
+      tmp = gfc_chainon_list (tmp, len1);
+      tmp = gfc_chainon_list (tmp, str1);
+      tmp = gfc_chainon_list (tmp, len2);
+      tmp = gfc_chainon_list (tmp, str2);
+
+      /* Build a call for the comparison.  */
+      tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
+    }
+
+  return tmp;
+}
 
 static void
 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
@@ -1818,6 +1866,17 @@ gfc_trans_string_copy (stmtblock_t * blo
 		       tree slen, tree src)
 {
   tree tmp;
+  tree dsc;
+  tree ssc;
+
+  /* Deal with single character specially.  */
+  dsc = gfc_to_single_character (dlen, dest);
+  ssc = gfc_to_single_character (slen, src);
+  if (dsc != NULL_TREE && ssc != NULL_TREE)
+    {
+      gfc_add_modify_expr (block, dsc, ssc);
+      return;
+    }
 
   tmp = NULL_TREE;
   tmp = gfc_chainon_list (tmp, dlen);