From patchwork Mon Feb 2 23:22:04 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Bernhard Reutner-Fischer X-Patchwork-Id: 435654 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 9F271140218 for ; Tue, 3 Feb 2015 10:24:57 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :to:cc:subject:date:message-id:in-reply-to:references :in-reply-to:references; q=dns; s=default; b=x652b2/a0IlxM0VYoPf uVwY/o37xkJHtTC+CSe+JTGze04Slryn8rv/1di0cV/+596UvLsq2jRPZivnPbRl nuKbK8WuPt/eBwBP3GrE4zbYJqGNKBSVZhIzzs/cY/NXd1WNQJZLrgX4K47lEK29 4GjSplv/ZjfWnoqt8RlIeJ+A= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :to:cc:subject:date:message-id:in-reply-to:references :in-reply-to:references; s=default; bh=iXJKdm8pUPWzMEV1+edb+4fim vg=; b=Gjb9oZiojY+cLXdpbNC+4Dj9DnGDi/txeNHTkCntiGQWMypoXzV3bX4CB Vu+1JcWItEO6VvprB/8q9+u91ExVBjlaFVXEyPZMPhL9aiKH78jXYtNxF7xWPiDZ Re07XvYIFRK+HWnBYaEl2XkRXwHaRXxo3alyI3328viNw0mMFU= Received: (qmail 7930 invoked by alias); 2 Feb 2015 23:22:14 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 7879 invoked by uid 89); 2 Feb 2015 23:22:14 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-2.4 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mail-wi0-f169.google.com Received: from mail-wi0-f169.google.com (HELO mail-wi0-f169.google.com) (209.85.212.169) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-GCM-SHA256 encrypted) ESMTPS; Mon, 02 Feb 2015 23:22:11 +0000 Received: by mail-wi0-f169.google.com with SMTP id h11so19021713wiw.0; Mon, 02 Feb 2015 15:22:08 -0800 (PST) X-Received: by 10.180.83.5 with SMTP id m5mr28997763wiy.74.1422919328491; Mon, 02 Feb 2015 15:22:08 -0800 (PST) Received: from s42.loc (91-119-229-249.dynamic.xdsl-line.inode.at. [91.119.229.249]) by mx.google.com with ESMTPSA id p6sm21908739wia.14.2015.02.02.15.22.06 (version=TLSv1.2 cipher=RC4-SHA bits=128/128); Mon, 02 Feb 2015 15:22:07 -0800 (PST) Received: from cow by s42.loc with local (Exim 4.80) (envelope-from ) id 1YIQJh-0007nu-Sx; Tue, 03 Feb 2015 00:22:05 +0100 From: Bernhard Reutner-Fischer To: Mike Stump Cc: Bernhard Reutner-Fischer , gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH, v0] fortran: !GCC$ unroll for DO Date: Tue, 3 Feb 2015 00:22:04 +0100 Message-Id: <1422919324-29964-2-git-send-email-rep.dot.nop@gmail.com> In-Reply-To: <1422919324-29964-1-git-send-email-rep.dot.nop@gmail.com> References: <1422919324-29964-1-git-send-email-rep.dot.nop@gmail.com> In-Reply-To: <23C2D250-F856-48E2-A460-1FC4674A60FB@comcast.net> References: <23C2D250-F856-48E2-A460-1FC4674A60FB@comcast.net> X-IsSubscribed: yes fortran/ChangeLog: 2015-02-02 Bernhard Reutner-Fischer * 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 * gfortran.dg/directive_unroll_1.f90: New testcase. * gfortran.dg/directive_unroll_2.f90: Likewise. Signed-off-by: Bernhard Reutner-Fischer --- 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 ("% 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 ("% 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 +