[PATCH, v0] fortran: !GCC$ unroll for DO

[Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>]

fortran/ChangeLog:

2015-02-02  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* match.h (gfc_match_gcc_unroll): New prototype.
	* decl.c (directive_unroll): New global variable.
	(gfc_match_gcc_unroll): New function.
	* gfortran.h (directive_unroll): New extern declaration.
	[gfc_iterator]: New member unroll.
	* parse.c (decode_gcc_attribute): Match "unroll".
	(parse_do_block): Set iterator's unroll.
	(parse_executable): Diagnose misplaced unroll directive.
	* trans.h (gfc_cfun_has_unroll): New prototype.
	* trans-decl.c (gfc_cfun_has_unroll): New function.
	* trans-stmt.c (gfc_trans_simple_do, gfc_trans_do): Annotate
	loop condition with annot_expr_unroll_kind.

testsuite/ChangeLog:

2015-02-02  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* gfortran.dg/directive_unroll_1.f90: New testcase.
	* gfortran.dg/directive_unroll_2.f90: Likewise.

Signed-off-by: Bernhard Reutner-Fischer <rep.dot.nop@gmail.com>
---
 gcc/fortran/decl.c                               | 38 ++++++++++++++++++++
 gcc/fortran/gfortran.h                           |  2 ++
 gcc/fortran/match.h                              |  1 +
 gcc/fortran/parse.c                              | 13 ++++++-
 gcc/fortran/trans-decl.c                         |  7 ++++
 gcc/fortran/trans-stmt.c                         | 14 ++++++++
 gcc/fortran/trans.h                              |  3 ++
 gcc/testsuite/gfortran.dg/directive_unroll_1.f90 | 46 ++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/directive_unroll_2.f90 | 39 ++++++++++++++++++++
 9 files changed, 162 insertions(+), 1 deletion(-)
 create mode 100644 gcc/testsuite/gfortran.dg/directive_unroll_1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/directive_unroll_2.f90

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 40d851c..713e6ee 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -103,6 +103,8 @@ gfc_symbol *gfc_new_block;
 
 bool gfc_matching_function;
 
+/* Set upon parsing a !GCC$ unroll n directive for use in the next loop.  */
+int directive_unroll = -1;
 
 /********************* DATA statement subroutines *********************/
 
@@ -8866,3 +8868,39 @@ syntax:
   gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
   return MATCH_ERROR;
 }
+
+
+/* Match a !GCC$ UNROLL statement of the form:
+      !GCC$ UNROLL n
+
+   The parameter n is the number of times we are supposed to unroll;
+   Refer to the C frontend and loop-unroll.c decide_unrolling() for details.
+
+   When we come here, we have already matched the !GCC$ UNROLL string.
+   */
+match
+gfc_match_gcc_unroll (void)
+{
+  signed int value;
+
+  if (gfc_match_small_int (&value) == MATCH_YES)
+    {
+      if (value < 0 || value > USHRT_MAX)
+	{
+	  gfc_error ("%<GCC unroll%> directive requires a"
+	      " non-negative integral constant"
+	      " less than or equal to %u at %C",
+	      USHRT_MAX
+	  );
+	  return MATCH_ERROR;
+	}
+      if (gfc_match_eos () == MATCH_YES)
+	{
+	  directive_unroll = value;
+	  return MATCH_YES;
+	}
+    }
+
+  gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
+  return MATCH_ERROR;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6b9f7dd..7bd2432 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2185,6 +2185,7 @@ gfc_case;
 typedef struct
 {
   gfc_expr *var, *start, *end, *step;
+  unsigned short unroll;
 }
 gfc_iterator;
 
@@ -2546,6 +2547,7 @@ gfc_finalizer;
 /* decl.c */
 bool gfc_in_match_data (void);
 match gfc_match_char_spec (gfc_typespec *);
+extern int directive_unroll;
 
 /* scanner.c */
 void gfc_scanner_done_1 (void);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 96d3ec1..30c0aa3 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -219,6 +219,7 @@ match gfc_match_contiguous (void);
 match gfc_match_dimension (void);
 match gfc_match_external (void);
 match gfc_match_gcc_attributes (void);
+match gfc_match_gcc_unroll (void);
 match gfc_match_import (void);
 match gfc_match_intent (void);
 match gfc_match_intrinsic (void);
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 2c7c554..95c35b9 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -882,6 +882,7 @@ decode_gcc_attribute (void)
   old_locus = gfc_current_locus;
 
   match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
+  match ("unroll", gfc_match_gcc_unroll, ST_NONE);
 
   /* All else has failed, so give up.  See if any of the matchers has
      stored an error message of some sort.  */
@@ -4020,7 +4021,14 @@ parse_do_block (void)
   s.ext.end_do_label = new_st.label1;
 
   if (new_st.ext.iterator != NULL)
-    stree = new_st.ext.iterator->var->symtree;
+    {
+      stree = new_st.ext.iterator->var->symtree;
+      if (directive_unroll != -1)
+	{
+	  new_st.ext.iterator->unroll = directive_unroll;
+	  directive_unroll = -1;
+	}
+    }
   else
     stree = NULL;
 
@@ -4745,6 +4753,9 @@ parse_executable (gfc_statement st)
 	  return st;
 	}
 
+      if (directive_unroll != -1)
+	gfc_error ("%<GCC unroll%> directive does not commence a loop at %C");
+
       st = next_statement ();
     }
 }
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 8a65d2b..3965541 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -6117,5 +6117,12 @@ gfc_process_block_locals (gfc_namespace* ns)
   saved_local_decls = NULL_TREE;
 }
 
+/* Hint to the ME that the current function has an unroll directive.  */
+
+void
+gfc_cfun_has_unroll (void)
+{
+  cfun->has_unroll = true;
+}
 
 #include "gt-fortran-trans-decl.h"
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 01bfd97..5379c7b 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1570,6 +1570,13 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
   cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
 			  to);
   cond = gfc_evaluate_now_loc (loc, cond, &body);
+  if (code->ext.iterator->unroll && cond != error_mark_node)
+    {
+      cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
+	  build_int_cst (integer_type_node, annot_expr_unroll_kind),
+	  build_int_cst (integer_type_node, code->ext.iterator->unroll));
+      gfc_cfun_has_unroll ();
+    }
 
   /* Increment the loop variable.  */
   tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
@@ -1870,6 +1877,13 @@ gfc_trans_do (gfc_code * code, tree exit_cond)
   /* End with the loop condition.  Loop until countm1t == 0.  */
   cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1t,
 			  build_int_cst (utype, 0));
+  if (code->ext.iterator->unroll && cond != error_mark_node)
+    {
+      cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
+	  build_int_cst (integer_type_node, annot_expr_unroll_kind),
+	  build_int_cst (integer_type_node, code->ext.iterator->unroll));
+      gfc_cfun_has_unroll ();
+    }
   tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
   tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
 			 cond, tmp, build_empty_stmt (loc));
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index bd1520a..fbd392b 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -665,6 +665,9 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
 /* Process the local variable decls of a block construct.  */
 void gfc_process_block_locals (gfc_namespace*);
 
+/* Hint to the ME that the current function has an unroll directive.  */
+void gfc_cfun_has_unroll (void);
+
 /* Output initialization/clean-up code that was deferred.  */
 void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);
 
diff --git a/gcc/testsuite/gfortran.dg/directive_unroll_1.f90 b/gcc/testsuite/gfortran.dg/directive_unroll_1.f90
new file mode 100644
index 0000000..ebaa2f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/directive_unroll_1.f90
@@ -0,0 +1,46 @@
+! { dg-do compile }
+! { dg-options "-O2 -fdump-rtl-loop2_unroll -fdump-tree-cunrolli-details" }
+! Test that
+! #pragma GCC unroll n
+! works
+
+! { dg-final { scan-tree-dump-not "note: loop turned into non-loop; it never loops" "cunrolli" } }
+
+subroutine simple1(n)
+  implicit NONE
+  integer (kind=1), intent(in) :: n
+  integer (kind=4) :: i
+!GCC$ unroll 8
+  DO i=0, n, 1
+    call dummy1(i)
+  ENDDO
+! { dg-final { scan-tree-dump "15:0: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine simple1
+
+subroutine simple2(a, b, n)
+  implicit NONE
+  integer (kind=1), intent(in) :: n
+  integer :: a(n), b(n)
+  integer (kind=4) :: i
+!GCC$ unroll 8
+  DO i=n, 0, -1
+    call dummy2(a(i), b(i), i)
+  ENDDO
+! { dg-final { scan-tree-dump "27:0: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine simple2
+
+subroutine not_simple1(a, b, n)
+  implicit NONE
+  integer (kind=1), intent(in) :: n
+  integer :: a(n), b(n)
+  integer (kind=4) :: i
+!GCC$ unroll 8
+  DO i=0, n, 2
+    call dummy2(a(i), b(i), i)
+  ENDDO
+! { dg-final { scan-tree-dump "38:0: note: loop unrolled 7 times" "loop2_unroll" } }
+! { dg-final { scan-tree-dump "38:0: note: not unrolling loop, user didn't want it unrolled completely" "cunrolli" } }
+end subroutine not_simple1
+
+! { dg-final { cleanup-tree-dump "cunrolli" } }
+! { dg-final { cleanup-rtl-dump "loop2_unroll" } }
diff --git a/gcc/testsuite/gfortran.dg/directive_unroll_2.f90 b/gcc/testsuite/gfortran.dg/directive_unroll_2.f90
new file mode 100644
index 0000000..59804a1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/directive_unroll_2.f90
@@ -0,0 +1,39 @@
+! { dg-do compile }
+
+! Test that
+! #pragma GCC unroll n
+! rejects invalid n and improper use
+
+subroutine wrong1(n)
+  implicit NONE
+  integer (kind=1), intent(in) :: n
+  integer (kind=4) :: i
+!GCC$ unroll 999999999 ! { dg-error "non-negative integral constant less than" }
+  DO i=0, n, 1
+    call dummy1(i)
+  ENDDO
+end subroutine wrong1
+
+subroutine wrong2(a, b, n)
+  implicit NONE
+  integer (kind=1), intent(in) :: n
+  integer :: a(n), b(n)
+  integer (kind=4) :: i
+!GCC$ unroll -1 ! { dg-error "non-negative integral constant less than" }
+  DO i=0, n, 2
+    call dummy2(a(i), b(i), i)
+  ENDDO
+end subroutine wrong2
+
+subroutine wrong3(a, b, n)
+  implicit NONE
+  integer (kind=1), intent(in) :: n
+  integer :: a(n), b(n)
+  integer (kind=4) :: i
+!GCC$ unroll 8
+  write (*,*) "wrong"! { dg-error "directive does not commence a loop" }
+  DO i=n, 0, -1
+    call dummy2(a(i), b(i), i)
+  ENDDO
+end subroutine wrong3
+
-- 
2.1.4