Hi,
this is the (hopefully) final implementation of the support for the unrolling
pragma in the Fortran front-end. However the documentation is still missing
because I don't really know where and under which form to put it.
Tested on x86_64-suse-linux, OK for the mainline?
2017-11-25 Bernhard Reutner-Fischer <al...@gcc.gnu.org>
Eric Botcazou <ebotca...@adacore.com>
fortran/ChangeLog:
* array.c (gfc_copy_iterator): Copy unroll field.
* decl.c (directive_unroll): New global variable.
(gfc_match_gcc_unroll): New function.
* gfortran.h (gfc_iterator]): Add unroll field.
(directive_unroll): Declare:
* match.c (gfc_match_do): Use memset to initialize the iterator.
* match.h (gfc_match_gcc_unroll): New prototype.
* parse.c (decode_gcc_attribute): Match "unroll".
(parse_do_block): Set iterator's unroll.
(parse_executable): Diagnose misplaced unroll directive.
* trans-stmt.c (gfc_trans_simple_do) Annotate loop condition with
annot_expr_unroll_kind.
(gfc_trans_do): Likewise.
testsuite/ChangeLog:
* gfortran.dg/directive_unroll_1.f90: New test.
* gfortran.dg/directive_unroll_2.f90: Likewise.
* gfortran.dg/directive_unroll_3.f90: Lkewise.
* gfortran.dg/directive_unroll_4.f90: Likewise.
* gfortran.dg/directive_unroll_5.f90: Likewise.
--
Eric BotcazouIndex: fortran/array.c
===================================================================
--- fortran/array.c (revision 255147)
+++ fortran/array.c (working copy)
@@ -2123,6 +2123,7 @@ gfc_copy_iterator (gfc_iterator *src)
dest->start = gfc_copy_expr (src->start);
dest->end = gfc_copy_expr (src->end);
dest->step = gfc_copy_expr (src->step);
+ dest->unroll = src->unroll;
return dest;
}
Index: fortran/decl.c
===================================================================
--- fortran/decl.c (revision 255147)
+++ fortran/decl.c (working copy)
@@ -95,6 +95,9 @@ 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;
+
/* If a kind expression of a component of a parameterized derived type is
parameterized, temporarily store the expression here. */
static gfc_expr *saved_kind_expr = NULL;
@@ -104,7 +107,6 @@ static gfc_expr *saved_kind_expr = NULL;
static gfc_actual_arglist *decl_type_param_list;
static gfc_actual_arglist *type_param_spec_list;
-
/********************* DATA statement subroutines *********************/
static bool in_match_data = false;
@@ -10943,3 +10945,37 @@ 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.
+
+ When we come here, we have already matched the !GCC$ UNROLL string. */
+match
+gfc_match_gcc_unroll (void)
+{
+ 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 == 0 ? 1 : value;
+ return MATCH_YES;
+ }
+ }
+
+ gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
+ return MATCH_ERROR;
+}
Index: fortran/gfortran.h
===================================================================
--- fortran/gfortran.h (revision 255147)
+++ fortran/gfortran.h (working copy)
@@ -2350,6 +2350,7 @@ gfc_case;
typedef struct
{
gfc_expr *var, *start, *end, *step;
+ unsigned short unroll;
}
gfc_iterator;
@@ -2724,6 +2725,7 @@ gfc_finalizer;
/* decl.c */
bool gfc_in_match_data (void);
match gfc_match_char_spec (gfc_typespec *);
+extern int directive_unroll;
/* Handling Parameterized Derived Types */
bool gfc_insert_kind_parameter_exprs (gfc_expr *);
Index: fortran/match.c
===================================================================
--- fortran/match.c (revision 255147)
+++ fortran/match.c (working copy)
@@ -2539,8 +2539,8 @@ gfc_match_do (void)
old_loc = gfc_current_locus;
+ memset (&iter, '\0', sizeof (gfc_iterator));
label = NULL;
- iter.var = iter.start = iter.end = iter.step = NULL;
m = gfc_match_label ();
if (m == MATCH_ERROR)
Index: fortran/match.h
===================================================================
--- fortran/match.h (revision 255147)
+++ fortran/match.h (working copy)
@@ -241,6 +241,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);
Index: fortran/parse.c
===================================================================
--- fortran/parse.c (revision 255147)
+++ fortran/parse.c (working copy)
@@ -1063,6 +1063,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. */
@@ -4635,7 +4636,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;
@@ -5393,6 +5401,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 ();
}
}
Index: fortran/trans-stmt.c
===================================================================
--- fortran/trans-stmt.c (revision 255147)
+++ fortran/trans-stmt.c (working copy)
@@ -1979,6 +1979,11 @@ gfc_trans_simple_do (gfc_code * code, st
fold_convert (type, 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));
/* The loop exit. */
tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
@@ -2305,6 +2310,11 @@ gfc_trans_do (gfc_code * code, tree exit
/* End with the loop condition. Loop until countm1t == 0. */
cond = fold_build2_loc (loc, EQ_EXPR, logical_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));
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));
Index: testsuite/gfortran.dg/directive_unroll_1.f90
===================================================================
--- testsuite/gfortran.dg/directive_unroll_1.f90 (revision 0)
+++ testsuite/gfortran.dg/directive_unroll_1.f90 (working copy)
@@ -0,0 +1,52 @@
+! { dg-do compile }
+! { dg-options "-O2 -fdump-tree-cunrolli-details -fdump-rtl-loop2_unroll-details" }
+! Test that
+! #pragma GCC unroll n
+! works
+
+subroutine test1(a)
+ implicit NONE
+ integer :: a(8)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, 8, 1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-tree-dump "12:.*: note: loop with 8 iterations completely unrolled" "cunrolli" } } */
+end subroutine test1
+
+subroutine test2(a, n)
+ implicit NONE
+ integer :: a(n)
+ integer (kind=1), intent(in) :: n
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, n, 1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "24:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test2
+
+subroutine test3(a, n)
+ implicit NONE
+ integer (kind=1), intent(in) :: n
+ integer :: a(n)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=n, 1, -1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "36:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test3
+
+subroutine test4(a, n)
+ implicit NONE
+ integer (kind=1), intent(in) :: n
+ integer :: a(n)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, n, 2
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "48:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test4
Index: testsuite/gfortran.dg/directive_unroll_2.f90
===================================================================
--- testsuite/gfortran.dg/directive_unroll_2.f90 (revision 0)
+++ testsuite/gfortran.dg/directive_unroll_2.f90 (working copy)
@@ -0,0 +1,52 @@
+! { dg-do compile }
+! { dg-options "-O -fdump-tree-cunroll-details -fdump-rtl-loop2_unroll-details" }
+! Test that
+! #pragma GCC unroll n
+! works
+
+subroutine test1(a)
+ implicit NONE
+ integer :: a(8)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, 8, 1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-tree-dump "12:.*: note: loop with 7 iterations completely unrolled" "cunroll" } } */
+end subroutine test1
+
+subroutine test2(a, n)
+ implicit NONE
+ integer :: a(n)
+ integer (kind=1), intent(in) :: n
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, n, 1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "24:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test2
+
+subroutine test3(a, n)
+ implicit NONE
+ integer (kind=1), intent(in) :: n
+ integer :: a(n)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=n, 1, -1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "36:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test3
+
+subroutine test4(a, n)
+ implicit NONE
+ integer (kind=1), intent(in) :: n
+ integer :: a(n)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, n, 2
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "48:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test4
Index: testsuite/gfortran.dg/directive_unroll_3.f90
===================================================================
--- testsuite/gfortran.dg/directive_unroll_3.f90 (revision 0)
+++ testsuite/gfortran.dg/directive_unroll_3.f90 (working copy)
@@ -0,0 +1,52 @@
+! { dg-do compile }
+! { dg-options "-O -fdisable-tree-cunroll -fdump-rtl-loop2_unroll-details" }
+! Test that
+! #pragma GCC unroll n
+! works
+
+subroutine test1(a)
+ implicit NONE
+ integer :: a(8)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, 8, 1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump-not "12:.: note: loop unrolled" "loop2_unroll" } }
+end subroutine test1
+
+subroutine test2(a, n)
+ implicit NONE
+ integer :: a(n)
+ integer (kind=1), intent(in) :: n
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, n, 1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "24:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test2
+
+subroutine test3(a, n)
+ implicit NONE
+ integer (kind=1), intent(in) :: n
+ integer :: a(n)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=n, 1, -1
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "36:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test3
+
+subroutine test4(a, n)
+ implicit NONE
+ integer (kind=1), intent(in) :: n
+ integer :: a(n)
+ integer (kind=4) :: i
+!GCC$ unroll 8
+ DO i=1, n, 2
+ call dummy(a(i))
+ ENDDO
+! { dg-final { scan-rtl-dump "48:.: note: loop unrolled 7 times" "loop2_unroll" } }
+end subroutine test4
Index: testsuite/gfortran.dg/directive_unroll_4.f90
===================================================================
--- testsuite/gfortran.dg/directive_unroll_4.f90 (revision 0)
+++ testsuite/gfortran.dg/directive_unroll_4.f90 (working copy)
@@ -0,0 +1,29 @@
+! { dg-do compile }
+! { dg-options "-O2 -funroll-all-loops -fdump-rtl-loop2_unroll-details -fdump-tree-cunrolli-details" }
+! Test that
+! #pragma GCC unroll n
+! works
+
+subroutine test1(a)
+ implicit NONE
+ integer :: a(8)
+ integer (kind=4) :: i
+!GCC$ unroll 0
+ DO i=1, 8, 1
+ call dummy(a(i))
+ ENDDO
+end subroutine test1
+
+subroutine test2(a, n)
+ implicit NONE
+ integer :: a(n)
+ integer (kind=1), intent(in) :: n
+ integer (kind=4) :: i
+!GCC$ unroll 0
+ DO i=1, n, 1
+ call dummy(a(i))
+ ENDDO
+end subroutine test2
+
+! { dg-final { scan-tree-dump "Not unrolling loop .: user didn't want it unrolled completely" "cunrolli" } } */
+! { dg-final { scan-rtl-dump-times "Not unrolling loop, user didn't want it unrolled" 2 "loop2_unroll" } } */
Index: testsuite/gfortran.dg/directive_unroll_5.f90
===================================================================
--- testsuite/gfortran.dg/directive_unroll_5.f90 (revision 0)
+++ testsuite/gfortran.dg/directive_unroll_5.f90 (working copy)
@@ -0,0 +1,38 @@
+! { 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=1, 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, 1, -1
+ call dummy2(a(i), b(i), i)
+ ENDDO
+end subroutine wrong3
