From: Nicolas Koenig <koenigni@student.ethz.ch>
To: "Dominique d'Humières" <dominiq@lps.ens.fr>,
"Bernhard Reutner-Fischer" <rep.dot.nop@gmail.com>
Cc: gfortran <fortran@gcc.gnu.org>, gcc-patches <gcc-patches@gcc.gnu.org>
Subject: Re: [Patch, fortran] PR35339 Optimize implied do loops in io statements
Date: Wed, 31 May 2017 19:11:00 -0000 [thread overview]
Message-ID: <84e2e0b8-26d2-bf0c-35ae-dd8f63a111fe@student.ethz.ch> (raw)
In-Reply-To: <638D5570-F9B9-4522-A123-CDC0B95D4227@lps.ens.fr>
[-- Attachment #1: Type: text/plain, Size: 1029 bytes --]
Hello Dominique,
attached is the next try, this time without stupidities (I hope). Both
test cases you posted don't ICE anymore.
Ok for trunk?
Nicolas
Regression tested for x86_64-pc-linux-gnu.
Changelog (still the same):
2017-05-27 Nicolas Koenig <koenigni@student.ethz.ch>
PR fortran/35339
* frontend-passes.c (traverse_io_block): New function.
(simplify_io_impl_do): New function.
(optimize_namespace): Invoke gfc_code_walker with
simplify_io_impl_do.
2017-05-27 Nicolas Koenig <koenigni@student.ethz.ch>
PR fortran/35339
* gfortran.dg/implied_do_io_1.f90: New Test.
On 05/31/2017 05:49 PM, Dominique d'Humières wrote:
>> Le 31 mai 2017 à 17:40, Dominique d'Humières <dominiq@lps.ens.fr> a écrit :
>>
>> If I am not mistaken, compiling the following code with the patch applied
> simpler test
>
> print *,(huge(0),i=1,6)
> ! print*,(i,i=1,6)
> ! print*,(i,i=10000,60000,10000)
> end
>
>> gives an ICE.
>>
>> TIA
>>
>> Dominique
[-- Attachment #2: p8.diff --]
[-- Type: text/x-patch, Size: 7691 bytes --]
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (revision 248539)
+++ frontend-passes.c (working copy)
@@ -1060,6 +1060,257 @@ convert_elseif (gfc_code **c, int *walk_subtrees A
return 0;
}
+struct do_stack
+{
+ struct do_stack *prev;
+ gfc_iterator *iter;
+ gfc_code *code;
+} *stack_top;
+
+/* Recursivly traverse the block of a WRITE or READ statement, and, can it be
+ optimized, do so. It optimizes it by replacing do loops with their analog
+ array slices. For example:
+
+ write (*,*) (a(i), i=1,4)
+
+ is replaced with
+
+ write (*,*) a(1:4:1) . */
+
+static bool
+traverse_io_block(gfc_code *code, bool *has_reached, gfc_code *prev)
+{
+ gfc_code *curr;
+ gfc_expr *new_e, *expr, *start;
+ gfc_ref *ref;
+ struct do_stack ds_push;
+ int i, future_rank = 0;
+ gfc_iterator *iters[GFC_MAX_DIMENSIONS];
+
+ /* Find the first transfer/do statement. */
+ for (curr = code; curr; curr = curr->next)
+ {
+ if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
+ break;
+ }
+
+ /* Ensure it is the only transfer/do statement because cases like
+
+ write (*,*) (a(i), b(i), i=1,4)
+
+ cannot be optimized. */
+
+ if (!curr || curr->next)
+ return false;
+
+ if (curr->op == EXEC_DO)
+ {
+ if (curr->ext.iterator->var->ref)
+ return false;
+ ds_push.prev = stack_top;
+ ds_push.iter = curr->ext.iterator;
+ ds_push.code = curr;
+ stack_top = &ds_push;
+ if (traverse_io_block(curr->block->next, has_reached, prev))
+ {
+ if (curr != stack_top->code && !*has_reached)
+ {
+ curr->block->next = NULL;
+ gfc_free_statements(curr);
+ }
+ else
+ *has_reached = true;
+ return true;
+ }
+ return false;
+ }
+
+ gcc_assert(curr->op == EXEC_TRANSFER);
+
+ ref = curr->expr1->ref;
+ if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
+ return false;
+
+ /* Find the iterators belonging to each variable and check conditions. */
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
+ || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
+ return false;
+
+ start = ref->u.ar.start[i];
+ gfc_simplify_expr(start, 0);
+ switch (start->expr_type)
+ {
+ case EXPR_VARIABLE:
+
+ /* write (*,*) (a(i), i=a%b,1) not handled yet. */
+ if (start->ref)
+ return false;
+
+ /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
+ if (!stack_top || !stack_top->iter
+ || stack_top->iter->var->symtree != start->symtree)
+ iters[i] = NULL;
+ else
+ {
+ iters[i] = stack_top->iter;
+ stack_top = stack_top->prev;
+ future_rank++;
+ }
+ break;
+ case EXPR_CONSTANT:
+ iters[i] = NULL;
+ break;
+ case EXPR_OP:
+ switch (start->value.op.op)
+ {
+ case INTRINSIC_PLUS:
+ case INTRINSIC_TIMES:
+ if (start->value.op.op1->expr_type != EXPR_VARIABLE)
+ std::swap(start->value.op.op1, start->value.op.op2);
+ gcc_fallthrough();
+ case INTRINSIC_MINUS:
+ if ((start->value.op.op1->expr_type!= EXPR_VARIABLE
+ && start->value.op.op2->expr_type != EXPR_CONSTANT)
+ || start->value.op.op1->ref)
+ return false;
+ if (!stack_top || !stack_top->iter
+ || stack_top->iter->var->symtree
+ != start->value.op.op1->symtree)
+ return false;
+ iters[i] = stack_top->iter;
+ stack_top = stack_top->prev;
+ break;
+ default:
+ return false;
+ }
+ future_rank++;
+ break;
+ default:
+ return false;
+ }
+ }
+
+ /* Create new expr. */
+ new_e = gfc_copy_expr(curr->expr1);
+ new_e->expr_type = EXPR_VARIABLE;
+ new_e->rank = future_rank;
+ if (curr->expr1->shape)
+ {
+ new_e->shape = gfc_get_shape(new_e->rank);
+ }
+
+
+ /* Assign new starts, ends and strides if necessary. */
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ if (!iters[i])
+ continue;
+ start = ref->u.ar.start[i];
+ switch (start->expr_type)
+ {
+ case EXPR_CONSTANT:
+ gfc_internal_error("bad expression");
+ break;
+ case EXPR_VARIABLE:
+ new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
+ new_e->ref->u.ar.type = AR_SECTION;
+ gfc_free_expr(new_e->ref->u.ar.start[i]);
+ new_e->ref->u.ar.start[i] = gfc_copy_expr(iters[i]->start);
+ new_e->ref->u.ar.end[i] = gfc_copy_expr(iters[i]->end);
+ new_e->ref->u.ar.stride[i] = gfc_copy_expr(iters[i]->step);
+ break;
+ case EXPR_OP:
+ new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
+ new_e->ref->u.ar.type = AR_SECTION;
+ gfc_free_expr(new_e->ref->u.ar.start[i]);
+ expr = gfc_copy_expr(start);
+ expr->value.op.op1 = gfc_copy_expr(iters[i]->start);
+ new_e->ref->u.ar.start[i] = expr;
+ gfc_simplify_expr(new_e->ref->u.ar.start[i], 0);
+ expr = gfc_copy_expr(start);
+ expr->value.op.op1 = gfc_copy_expr(iters[i]->end);
+ new_e->ref->u.ar.end[i] = expr;
+ gfc_simplify_expr(new_e->ref->u.ar.end[i], 0);
+ switch(start->value.op.op)
+ {
+ case INTRINSIC_MINUS:
+ case INTRINSIC_PLUS:
+ new_e->ref->u.ar.stride[i] = gfc_copy_expr(iters[i]->step);
+ break;
+ case INTRINSIC_TIMES:
+ expr = gfc_copy_expr(start);
+ expr->value.op.op1 = gfc_copy_expr(iters[i]->step);
+ new_e->ref->u.ar.stride[i] = expr;
+ gfc_simplify_expr(new_e->ref->u.ar.stride[i], 0);
+ break;
+ default:
+ gfc_internal_error("bad op");
+ }
+ break;
+ default:
+ gfc_internal_error("bad expression");
+ }
+ }
+ curr->expr1 = new_e;
+
+ /* Insert modified statement. Check whether the statement needs to be
+ inserted at the lowest level. */
+ if (!stack_top->iter)
+ {
+ if (prev)
+ {
+ curr->next = prev->next->next;
+ prev->next = curr;
+ }
+ else
+ {
+ curr->next = stack_top->code->block->next->next->next;
+ stack_top->code->block->next = curr;
+ }
+ }
+ else
+ stack_top->code->block->next = curr;
+ return true;
+}
+
+/* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
+ tries to optimize its block. */
+
+static int
+simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code **curr, *prev = NULL;
+ struct do_stack write, first;
+ bool b = false;
+ *walk_subtrees = 1;
+ if (!(*code)->block || ((*code)->block->op != EXEC_WRITE
+ && (*code)->block->op != EXEC_READ))
+ return 0;
+
+ *walk_subtrees = 0;
+ write.prev = NULL;
+ write.iter = NULL;
+ write.code = *code;
+
+ for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
+ {
+ if ((*curr)->op == EXEC_DO)
+ {
+ first.prev = &write;
+ first.iter = (*curr)->ext.iterator;
+ first.code = *curr;
+ stack_top = &first;
+ traverse_io_block((*curr)->block->next, &b, prev);
+ stack_top = NULL;
+ }
+ prev = *curr;
+ }
+ return 0;
+}
+
/* Optimize a namespace, including all contained namespaces. */
static void
@@ -1073,6 +1324,7 @@ optimize_namespace (gfc_namespace *ns)
in_assoc_list = false;
in_omp_workshare = false;
+ gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
[-- Attachment #3: implied_do_io_1.f90 --]
[-- Type: text/x-fortran, Size: 1744 bytes --]
! { dg-do run }
! { dg-options "-O -fdump-tree-original" }
! PR/35339
! This test ensures optimization of implied do loops in io statements
program main
implicit none
integer:: i, j, square
integer, parameter:: k = 2, linenum = 14
integer, dimension(2):: a = [(i, i=1,2)]
integer, dimension(2,2):: b = reshape([1, 2, 3, 4], shape(b))
character (len=30), dimension(linenum) :: res
character (len=30) :: line
type tp
integer, dimension(2):: i
end type
type(tp), dimension(2):: t = [tp([1, 2]), tp([1, 2])]
data res / &
' a 2 2', &
' b 1 2', &
' c 1 2', &
' d 1 2', &
' e 1 2 1 2', &
' f 1 2 1 1 2 2', &
' g 1 2 3 4', &
' h 1 3 2 4', &
' i 2', &
' j 2', &
' k 1 2 1 2', &
' l 1', &
' m 1 1', &
' n 1 2'/
open(10,file="test.dat")
write (10,1000) 'a', (a(k), i=1,2)
write (10,1000) 'b', (b(i, 1), i=1,2)
write (10,1000) 'c', b(1:2:1, 1)
write (10,1000) 'd', (a(i), i=1,2)
write (10,1000) 'e', ((a(i), i=1,2), j=1,2)
write (10,1000) 'f', (a, b(i, 1), i = 1,2)
write (10,1000) 'g', ((b(i, j), i=1,2),j=1,2)
write (10,1000) 'h', ((b(j, i), i=1,2),j=1,2)
write (10,1000) 'i', (a(i+1), i=1,1)
write (10,1000) 'j', (a(i*2), i=1,1)
write (10,1000) 'k', (a(i), i=1,2), (a(i), i=1,2)
write (10,1000) 'l', (a(i), i=1,1)
write (10,1000) 'm', (1, i=1,2)
write (10,1000) 'n', (t(i)%i(i), i=1,2)
rewind (10)
do i=1,linenum
read (10,'(A)') line
if (line .ne. res(i)) call abort
end do
close(10,status="delete")
1000 format (A2,100I4)
end program main
! { dg-final { scan-tree-dump-times "while" 7 "original" } }
next prev parent reply other threads:[~2017-05-31 19:03 UTC|newest]
Thread overview: 20+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-05-29 15:49 Dominique d'Humières
2017-05-29 16:08 ` Nicolas Koenig
2017-05-29 16:34 ` Dominique d'Humières
2017-05-31 6:49 ` Bernhard Reutner-Fischer
2017-05-31 15:49 ` Dominique d'Humières
2017-05-31 16:04 ` Dominique d'Humières
2017-05-31 19:11 ` Nicolas Koenig [this message]
2017-05-31 23:34 ` Bernhard Reutner-Fischer
2017-06-01 9:31 ` Dominique d'Humières
2017-06-01 14:19 ` Dominique d'Humières
2017-06-01 14:37 ` Dominique d'Humières
2017-06-03 13:48 ` Nicolas Koenig
2017-06-03 16:25 ` Jerry DeLisle
2017-06-03 18:12 ` Bernhard Reutner-Fischer
2017-06-05 20:39 ` Nicolas Koenig
2017-06-06 11:05 ` Markus Trippelsdorf
2017-06-07 15:13 ` Renlin Li
2017-11-02 8:25 ` [testsuite, committed] Fix scan pattern in gfortran.dg/implied_do_io_1.f90 Tom de Vries
-- strict thread matches above, loose matches on Subject: below --
2017-05-27 21:47 [Patch, fortran] PR35339 Optimize implied do loops in io statements Nicolas Koenig
2017-05-28 22:09 ` Jerry DeLisle
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=84e2e0b8-26d2-bf0c-35ae-dd8f63a111fe@student.ethz.ch \
--to=koenigni@student.ethz.ch \
--cc=dominiq@lps.ens.fr \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=rep.dot.nop@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).