Async I/O patch with compilation fix
Hello everyone,
Here is an updated version of the patch that hopefully fixes the compilation
problems by disabling async I/O if conditions are not supported by the target.
I would appreciate if people could test it on systems on which it failed
before. As for the array_constructor_8.f90 failure reported in the PR, why
it fails is beyond me, it doesn't even use I/O. Maybe/Probably something
unrelated?
Nicolas
2018-08-02 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* gfortran.texi: Add description of asynchronous I/O.
* trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables
as volatile.
* trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to
st_wait_async and change argument spec from ".X" to ".w".
(gfc_trans_wait): Pass ID argument via reference.
2018-08-02 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* gfortran.dg/f2003_inquire_1.f03: Add write statement.
* gfortran.dg/f2003_io_1.f03: Add wait statement.
2018-08-02 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* Makefile.am: Add async.c to gfor_io_src.
Add async.h to gfor_io_headers.
* Makefile.in: Regenerated.
* gfortran.map: Add _gfortran_st_wait_async.
* io/async.c: New file.
* io/async.h: New file.
* io/close.c: Include async.h.
(st_close): Call async_wait for an asynchronous unit.
* io/file_pos.c (st_backspace): Likewise.
(st_endfile): Likewise.
(st_rewind): Likewise.
(st_flush): Likewise.
* io/inquire.c: Add handling for asynchronous PENDING
and ID arguments.
* io/io.h (st_parameter_dt): Add async bit.
(st_parameter_wait): Correct.
(gfc_unit): Add au pointer.
(st_wait_async): Add prototype.
(transfer_array_inner): Likewise.
(st_write_done_worker): Likewise.
* io/open.c: Include async.h.
(new_unit): Initialize asynchronous unit.
* io/transfer.c (async_opt): New struct.
(wrap_scalar_transfer): New function.
(transfer_integer): Call wrap_scalar_transfer to do the work.
(transfer_real): Likewise.
(transfer_real_write): Likewise.
(transfer_character): Likewise.
(transfer_character_wide): Likewise.
(transfer_complex): Likewise.
(transfer_array_inner): New function.
(transfer_array): Call transfer_array_inner.
(transfer_derived): Call wrap_scalar_transfer.
(data_transfer_init): Check for asynchronous I/O.
Perform a wait operation on any pending asynchronous I/O
if the data transfer is synchronous. Copy PDT and enqueue
thread for data transfer.
(st_read_done_worker): New function.
(st_read_done): Enqueue transfer or call st_read_done_worker.
(st_write_done_worker): New function.
(st_write_done): Enqueue transfer or call st_read_done_worker.
(st_wait): Document as no-op for compatibility reasons.
(st_wait_async): New function.
* io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK;
add NOTE where necessary.
(get_gfc_unit): Likewise.
(init_units): Likewise.
(close_unit_1): Likewise. Call async_close if asynchronous.
(close_unit): Use macros LOCK and UNLOCK.
(finish_last_advance_record): Likewise.
(newunit_alloc): Likewise.
* io/unix.c (find_file): Likewise.
(flush_all_units_1): Likewise.
(flush_all_units): Likewise.
* libgfortran.h (generate_error_common): Add prototype.
* runtime/error.c: Include io.h and async.h.
(generate_error_common): New function.
2018-08-02 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* testsuite/libgomp.fortran/async_io_1.f90: New test.
* testsuite/libgomp.fortran/async_io_2.f90: New test.
* testsuite/libgomp.fortran/async_io_3.f90: New test.
* testsuite/libgomp.fortran/async_io_4.f90: New test.
* testsuite/libgomp.fortran/async_io_5.f90: New test.
* testsuite/libgomp.fortran/async_io_6.f90: New test.
* testsuite/libgomp.fortran/async_io_7.f90: New test.
Index: gcc/fortran/gfortran.texi
===
--- gcc/fortran/gfortran.texi (revision 263244)
+++ gcc/fortran/gfortran.texi (working copy)
@@ -879,8 +879,7 @@ than @code{(/.../)}. Type-specification for array
@item Extensions to the specification and initialization expressions,
including the support for intrinsics with real and complex arguments.
-@item Support for the asynchronous input/output syntax; however, the
-data transfer is currently always synchronously performed.
+@item Support for the asynchronous input/output.
@item
@cindex @code{FLUSH} statement
@@ -1183,6 +1182,7 @@ might in some way or
Re: Async I/O patch with compilation fix
On Thu, Aug 02, 2018 at 05:42:46PM +0200, Christophe Lyon wrote: > On Thu, 2 Aug 2018 at 13:35, Nicolas Koenig wrote: > > > > > > Hello everyone, > > > > Here is an updated version of the patch that hopefully fixes the compilation > > problems by disabling async I/O if conditions are not supported by the > > target. > > > > I would appreciate if people could test it on systems on which it failed > > before. As for the array_constructor_8.f90 failure reported in the PR, why > > it fails is beyond me, it doesn't even use I/O. Maybe/Probably something > > unrelated? > > > > Hi, > I'm probably missing something obvious, but after applying this patch > on top of r263136, the builds fail while building libgfortran: > /tmp/9271913_1.tmpdir/aci-gcc-fsf/sources/gcc-fsf/gccsrc/libgfortran/runtime/error.c:28:10: > fatal error: async.h: No such file or directory > #include "async.h" > ^ > compilation terminated. > make[3]: *** [error.lo] Error 1 > Hi, It wasn't you who missed something obvious. Typing `svn add` is hard. Here is a version of the patch with the two new files. Nicolas > > Nicolas > > > > > > 2018-08-02 Nicolas Koenig > > Thomas Koenig > > > > PR fortran/25829 > > * gfortran.texi: Add description of asynchronous I/O. > > * trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables > > as volatile. > > * trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to > > st_wait_async and change argument spec from ".X" to ".w". > > (gfc_trans_wait): Pass ID argument via reference. > > > > 2018-08-02 Nicolas Koenig > > Thomas Koenig > > > > PR fortran/25829 > > * gfortran.dg/f2003_inquire_1.f03: Add write statement. > > * gfortran.dg/f2003_io_1.f03: Add wait statement. > > > > 2018-08-02 Nicolas Koenig > > Thomas Koenig > > > > PR fortran/25829 > > * Makefile.am: Add async.c to gfor_io_src. > > Add async.h to gfor_io_headers. > > * Makefile.in: Regenerated. > > * gfortran.map: Add _gfortran_st_wait_async. > > * io/async.c: New file. > > * io/async.h: New file. > > * io/close.c: Include async.h. > > (st_close): Call async_wait for an asynchronous unit. > > * io/file_pos.c (st_backspace): Likewise. > > (st_endfile): Likewise. > > (st_rewind): Likewise. > > (st_flush): Likewise. > > * io/inquire.c: Add handling for asynchronous PENDING > > and ID arguments. > > * io/io.h (st_parameter_dt): Add async bit. > > (st_parameter_wait): Correct. > > (gfc_unit): Add au pointer. > > (st_wait_async): Add prototype. > > (transfer_array_inner): Likewise. > > (st_write_done_worker): Likewise. > > * io/open.c: Include async.h. > > (new_unit): Initialize asynchronous unit. > > * io/transfer.c (async_opt): New struct. > > (wrap_scalar_transfer): New function. > > (transfer_integer): Call wrap_scalar_transfer to do the work. > > (transfer_real): Likewise. > > (transfer_real_write): Likewise. > > (transfer_character): Likewise. > > (transfer_character_wide): Likewise. > > (transfer_complex): Likewise. > > (transfer_array_inner): New function. > > (transfer_array): Call transfer_array_inner. > > (transfer_derived): Call wrap_scalar_transfer. > > (data_transfer_init): Check for asynchronous I/O. > > Perform a wait operation on any pending asynchronous I/O > > if the data transfer is synchronous. Copy PDT and enqueue > > thread for data transfer. > > (st_read_done_worker): New function. > > (st_read_done): Enqueue transfer or call st_read_done_worker. > > (st_write_done_worker): New function. > > (st_write_done): Enqueue transfer or call st_read_done_worker. > > (st_wait): Document as no-op for compatibility reasons. > > (st_wait_async): New function. > > * io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK; > > add NOTE where necessary. > > (get_gfc_unit): Likewise. > > (init_units): Likewise. > > (close_unit_1): Likewise. Call async_close if asynchronous. > >
[Patch, Fortran] PR25829: Asynchronous I/O
Hello everyone,
this patch adds asynchronous I/O support. Thomas and I finally finished
a feature-complete and debugged version, so here it is. In order to use
asynchronous I/O, it is still necessary to link against libpthread,
libgomp or another library linked against any of the aforementioned two.
While it might not be the nicest way, it at least keeps in line with the
likes of ifort. Two of the test I send deal with asynchronous error
handling, so they will fail if not linked accordingly.
Since the implementation relies on pthreads, it would be great if
somebody could try the patch on non-linux targets, to see whether it
causes any problems there.
Let the rain of regressions begin ;)
Nicolas
P.S.: I would very much recommend removing the #undef DEBUG in async.h.
I have to admit, I am quite proud of the debug printouts. They even
build a data structure in the background telling you were a locked mutex
was locked.
Regression tested cleanly on x86_64-pc-linux-gnu.
2018-06-03 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables
as volatile.
* trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to
st_wait_async and change argument spec from ".X" to ".w".
(gfc_trans_wait): Pass ID argument via reference.
2018-06-03 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* Makefile.am: Add async.c to gfor_io_src.
Add async.h to gfor_io_headers.
* Makefile.in: Regenerated.
* gfortran.map: Add _gfortran_st_wait_async.
* io/async.c: New file.
* io/async.h: New file.
* io/close.c: Include async.h.
(st_close): Call async_wait for an asynchronous unit.
* io/file_pos.c (st_backspace): Likewise.
(st_endfile): Likewise.
(st_rewind): Likewise.
(st_flush): Likewise.
* io/inquire.c: Add handling for asynchronous PENDING
and ID arguments.
* io/io.h (st_parameter_dt): Add async bit.
(st_parameter_wait): Correct.
(gfc_unit): Add au pointer.
(st_wait_async): Add prototype.
(transfer_array_inner): Likewise.
(st_write_done_worker): Likewise.
* io/open.c: Include async.h.
(new_unit): Initialize asynchronous unit.
* io/transfer.c (async_opt): New struct.
(wrap_scalar_transfer): New function.
(transfer_integer): Call wrap_scalar_transfer to do the work.
(transfer_real): Likewise.
(transfer_real_write): Likewise.
(transfer_character): Likewise.
(transfer_character_wide): Likewise.
(transfer_complex): Likewise.
(transfer_array_inner): New function.
(transfer_array): Call transfer_array_inner.
(transfer_derived): Call wrap_scalar_transfer.
(data_transfer_init): Check for asynchronous I/O.
Perform a wait operation on any pending asynchronous I/O
if the data transfer is synchronous. Copy PDT and enqueue
thread for data transfer.
(st_read_done_worker): New function.
(st_read_done): Enqueue transfer or call st_read_done_worker.
(st_write_done_worker): New function.
(st_write_done): Enqueue transfer or call st_read_done_worker.
(st_wait): Document as no-op for compatibility reasons.
(st_wait_async): New function.
* io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK;
add NOTE where necessary.
(get_gfc_unit): Likewise.
(init_units): Likewise.
(close_unit_1): Likewise. Call async_close if asynchronous.
(close_unit): Use macros LOCK and UNLOCK.
(finish_last_advance_record): Likewise.
(newunit_alloc): Likewise.
* io/unix.c (find_file): Likewise.
(flush_all_units_1): Likewise.
(flush_all_units): Likewise.
* libgfortran.h (generate_error_common): Add prototype.
* runtime/error.c: Include io.h and async.h.
(generate_error_common): New function.
2018-06-03 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* testsuite/libgfomp.fortran/asynchronous_6.f90: New test.
* testsuite/libgfomp.fortran/asynchronous_8.f90: New test.
Index: gcc/fortran/trans-decl.c
===
--- gcc/fortran/trans-decl.c (Revision 259739)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -699,7 +699,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
&& CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
TREE_STATIC (decl) = 1;
- if (sym->attr.volatile_)
+ /* Treat asynchronous variables the same as volatile, for now. */
+ if (sym->attr.volatile_ || sym->attr.asynchronous)
{
TREE_THIS_VOLATILE (decl) = 1;
TREE_SIDE_EFFECT
Re: [Patch, Fortran] PR25829: Asynchronous I/O (v2)
Hi Dominique and Rainer, First of all thanks for testing! Hi Dominique, Nicolas, I have applied your patch on top of revision r261130 on x86_64-apple-darwin17 (SSD with APFS file system). I've tried it on i386-pc-solaris2.11 and sparc-sun-solaris2.11. I also see two regressions FAIL: gfortran.dg/f2003_inquire_1.f03 -O1 execution test only with -m32 and -O1 (STOP 5), and It fails for me at -O[0s] (i386) resp. -O[01] (sparc), 64-bit only. This seems to be a bug in the test suite. It tries to find out whether an id is pending that is never initialized. FAIL: gfortran.dg/f2003_io_1.f03 -O* with both -m32 and -m64 (STOP 1). Same here: FAILs at -O[0-3s] for both 32 and 64-bit. And another bug in the test suite. This time the wait after the read is missing. The is also typos for the added tests s/libgfomp/libgomp/ Will fix. Why do the tests start at asynchronous_6.f90? Because they were originally intended for the gfortran test suite, but I couldn't run it there because of libpthread. I will change the numbering scheme. ... and asynchronous_9.f90 is missing from the ChangeLog, which ..._7.f90 is missing from the sequence. asynchronous_7.f90 is a test for an error, but dg-shouldfail is not working in libgomp. Dominique is looking into this. Besides, I see +FAIL: libgomp.fortran/asynchronous_6.f90 -O1 execution test STOP 2 32-bit i386 only. I have trouble replicating this bug even with -m32. Could you get some more debugging info for the test on your machine? +FAIL: libgomp.fortran/asynchronous_9.f90 -O execution test 32 and 64-bit i386 and sparc, no error message. This file wasn't supposed to be a test case, that's why it is not in the ChangeLog. It is a benchmark program, so it takes some time. Maybe a time out? Could you maybe try running it outside the test suite? Rainer Dominique wrote: > "Treat asynchronous variables the same as volatile, for now." could probably simplified as > "Treat asynchronous variables as volatile, for now." Will do. > > I also wonder if > > +wrap_scalar_transfer (dtp, BT_INTEGER, p, kind, kind, 1); > > is correct without a cast to size_t for the last two arguments (and for the last argument in other instances). Note that I am C challenged, so forgive the question if it is stupid. It atomatically casts based on the type information in the prototype in io.h. > > Thanks for the nice work. With pleasure! :) > > Dominique
[patch, fortran] PR25829 Asynchronous I/O (patch version 2.0)
Hey everyone,
Here is the next version of the async I/O patch. It adds the
documentation, renames the testcases, uses "gthr.h", follows the style
guidelines and has been regression tested cleanly.
As for adding additional flags, I think it would be better to follow
ifort to minimize complexity.
The benchmark (not for the test suite) should also run on systems with
small stack sizes.
I hope I forgot nothing.
Nicolas
2018-06-16 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* gfortran.texi: Add description of asynchronous I/O.
* trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables
as volatile.
* trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to
st_wait_async and change argument spec from ".X" to ".w".
(gfc_trans_wait): Pass ID argument via reference.
2018-06-16 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* gfortran.dg/f2003_inquire_1.f03: Add write statement.
* gfortran.dg/f2003_io_1.f03: Add wait statement.
2018-06-16 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* Makefile.am: Add async.c to gfor_io_src.
Add async.h to gfor_io_headers.
* Makefile.in: Regenerated.
* gfortran.map: Add _gfortran_st_wait_async.
* io/async.c: New file.
* io/async.h: New file.
* io/close.c: Include async.h.
(st_close): Call async_wait for an asynchronous unit.
* io/file_pos.c (st_backspace): Likewise.
(st_endfile): Likewise.
(st_rewind): Likewise.
(st_flush): Likewise.
* io/inquire.c: Add handling for asynchronous PENDING
and ID arguments.
* io/io.h (st_parameter_dt): Add async bit.
(st_parameter_wait): Correct.
(gfc_unit): Add au pointer.
(st_wait_async): Add prototype.
(transfer_array_inner): Likewise.
(st_write_done_worker): Likewise.
* io/open.c: Include async.h.
(new_unit): Initialize asynchronous unit.
* io/transfer.c (async_opt): New struct.
(wrap_scalar_transfer): New function.
(transfer_integer): Call wrap_scalar_transfer to do the work.
(transfer_real): Likewise.
(transfer_real_write): Likewise.
(transfer_character): Likewise.
(transfer_character_wide): Likewise.
(transfer_complex): Likewise.
(transfer_array_inner): New function.
(transfer_array): Call transfer_array_inner.
(transfer_derived): Call wrap_scalar_transfer.
(data_transfer_init): Check for asynchronous I/O.
Perform a wait operation on any pending asynchronous I/O
if the data transfer is synchronous. Copy PDT and enqueue
thread for data transfer.
(st_read_done_worker): New function.
(st_read_done): Enqueue transfer or call st_read_done_worker.
(st_write_done_worker): New function.
(st_write_done): Enqueue transfer or call st_read_done_worker.
(st_wait): Document as no-op for compatibility reasons.
(st_wait_async): New function.
* io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK;
add NOTE where necessary.
(get_gfc_unit): Likewise.
(init_units): Likewise.
(close_unit_1): Likewise. Call async_close if asynchronous.
(close_unit): Use macros LOCK and UNLOCK.
(finish_last_advance_record): Likewise.
(newunit_alloc): Likewise.
* io/unix.c (find_file): Likewise.
(flush_all_units_1): Likewise.
(flush_all_units): Likewise.
* libgfortran.h (generate_error_common): Add prototype.
* runtime/error.c: Include io.h and async.h.
(generate_error_common): New function.
2018-06-16 Nicolas Koenig
Thomas Koenig
PR fortran/25829
* testsuite/libgfomp.fortran/async_io_1.f90: New test.
* testsuite/libgfomp.fortran/async_io_2.f90: New test.
* testsuite/libgfomp.fortran/async_io_3.f90: New test.
program main
implicit none
integer, parameter :: n = 10**7
character(3), parameter :: yes = "yes"
real, dimension(:), allocatable :: a,b,c
allocate (a(n), b(n), c(n))
call random_number(a)
call random_number(b)
call random_number(c)
open (10, file="a.dat",asynchronous=yes)
open (20, file="b.dat",asynchronous=yes)
open (30, file="c.dat",asynchronous=yes)
write (10,*,asynchronous=yes) a
write (20,*,asynchronous=yes) b
write (30,*,asynchronous=yes) c
wait (10)
wait (20)
wait (30)
end program main
! { dg-do run }
! Check basic functionality of async I/O
program main
implicit none
integer:: i=1, j=2, k, l
real :: a, b, c, d
character(3), parameter:: yes="yes"
character(4) :: str
complex :: cc, dd
integer, dimension(4):: is = [0, 1, 2, 3]
integer, dimension(4):: res
character(10) :: inq
open (
[patch, rfc] Fortran async I/O support
nc.c' || echo '$(srcdir)/'`io/async.c
+
associated.lo: intrinsics/associated.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT associated.lo -MD -MP -MF $(DEPDIR)/associated.Tpo -c -o associated.lo `test -f 'intrinsics/associated.c' || echo '$(srcdir)/'`intrinsics/associated.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/associated.Tpo $(DEPDIR)/associated.Plo
Index: libgfortran/io/async.c
===
--- libgfortran/io/async.c (nicht existent)
+++ libgfortran/io/async.c (Arbeitskopie)
@@ -0,0 +1,380 @@
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+ Contributed by Nicolas Koenig
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#define _GTHREAD_USE_COND_INIT_FUNC
+#include "../../libgcc/gthr-posix.h"
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include
+#include
+
+#include
+
+#include "async.h"
+
+DEBUG_LINE(__thread const char *aio_prefix = MPREFIX);
+
+__thread gfc_unit *thread_unit = NULL;
+
+typedef struct transfer_queue
+{
+ enum aio_do type;
+ struct transfer_queue *next;
+ struct st_parameter_dt *new_pdt;
+ transfer_args arg;
+ _Bool has_id;
+} transfer_queue;
+
+struct error {
+ st_parameter_dt *dtp;
+ int id;
+};
+
+static void
+update_pdt(st_parameter_dt **old, st_parameter_dt *new) {
+ st_parameter_dt *temp;
+ NOTE("Changing pdts");
+ temp = *old;
+ *old = new;
+ if(temp)
+free(temp);
+}
+
+static void
+destroy_adv_cond (struct adv_cond * ac)
+{
+ T_ERROR (__gthread_mutex_destroy, &ac->lock);
+ T_ERROR (__gthread_cond_destroy, &ac->signal);
+}
+
+static void *
+async_io (void *arg)
+{
+ DEBUG_LINE(aio_prefix = TPREFIX);
+ transfer_queue *ctq = NULL, *prev = NULL;
+ gfc_unit *u = (gfc_unit *) arg;
+ async_unit *au = u->au;
+ thread_unit = u;
+ LOCK (au, lock);
+ au->thread = __gthread_self ();
+ UNLOCK (au, lock);
+ while (true)
+{
+ WAIT_SIGNAL (&au->work, au->tail || au->finished);
+ LOCK (au, lock);
+ ctq = au->head;
+ prev = NULL;
+ while (ctq)
+ {
+ if (prev)
+ free (prev);
+ prev = ctq;
+ if (!au->error.has_error)
+ {
+ UNLOCK (au, lock);
+
+ switch(ctq->type)
+ {
+ case AIO_WRITE_DONE:
+ NOTE("Finalizing write");
+ st_write_done_worker (au->pdt);
+ break;
+ case AIO_READ_DONE:
+ NOTE("Finalizing read");
+ st_read_done_worker (au->pdt);
+ break;
+ case AIO_CHANGE_PDT:
+ update_pdt(&au->pdt, ctq->new_pdt);
+ break;
+ case AIO_TRANSFER_SCALAR:
+ NOTE("Starting scalar transfer");
+ ctq->arg.scalar.transfer (au->pdt, ctq->arg.scalar.arg_bt,
+ ctq->arg.scalar.data,
+ ctq->arg.scalar.i,
+ ctq->arg.scalar.s1,
+ ctq->arg.scalar.s2);
+ break;
+ case AIO_TRANSFER_ARRAY:
+ NOTE("Starting array transfer");
+ transfer_array_inner(au->pdt, ctq->arg.array.desc,
+ ctq->arg.array.kind,
+ ctq->arg.array.charlen);
+ break;
+ default:
+ ERROR(-1, "Invalid queue type %d", ctq->type);
+ break;
+ }
+ LOCK (au, lock);
+ if (unlikely (au->error.has_error))
+ {
+ au->error.last_good_id = au->id.low - 1;
+ unlock_unit (au->pdt->u.p.current_unit);
+ }
+ }
+ NOTE("Current id: %d", au->id.low);
+ if (ctq->has_id && au->id.waiting == au->id.low++)
+ SIGNAL (&au->id.done);
+ ctq = ctq->next;
+ }
+ au->tail = NULL;
+ au->head = NULL;
+ SIGNAL (&au->emptysignal);
+ au->empty = 1;
+ if (au->finished)
+ break;
+ UNLOCK (au, lock);
+}
+ UNLOCK (au, lock);
+
[Patch, fortran] PR80442 Handle DATA statement with iteration var in array slice
Hello everyone,
since everybody seems to be submitting patches the last few days, I
thought I might as well :)
Attached is a patch that makes the compiler capable of dealing with
implied do variables in
array slices in data statements.
The copying of the expressions is necessary since
gfc_simplify_expr(expr, 1) substitutes every
symbol in expr that is on the iter_stack with its value.
Ok for trunk?
Nicolas
Regression tested for x86_64-pc-linux-gnu.
Changelog:
2017-05-09 Nicolas Koenig
PR fortran/80442
* array.c (gfc_ref_dimen_size): Simplify stride
expression
* data.c (gfc_advance_section): Simplify start,
end and stride expressions
(gfc_advance_section): Simplify start and end
expressions
(gfc_get_section_index): Simplify start expression
2017-05-09 Nicolas Koenig
PR fortran/80442
* gfortran.dg/impl_do_var_data.f90: New Test
Index: array.c
===
--- array.c (revision 247809)
+++ array.c (working copy)
@@ -2201,6 +2201,7 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen,
mpz_t upper, lower, stride;
mpz_t diff;
bool t;
+ gfc_expr *stride_expr = NULL;
if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
@@ -2225,12 +2226,16 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen,
mpz_set_ui (stride, 1);
else
{
- if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
+ stride_expr = gfc_copy_expr(ar->stride[dimen]);
+ if(!gfc_simplify_expr(stride_expr, 1))
+ gfc_internal_error("Simplification error");
+ if (stride_expr->expr_type != EXPR_CONSTANT)
{
mpz_clear (stride);
return false;
}
- mpz_set (stride, ar->stride[dimen]->value.integer);
+ mpz_set (stride, stride_expr->value.integer);
+ gfc_free_expr(stride_expr);
}
/* Calculate the number of elements via gfc_dep_differce, but only if
Index: data.c
===
--- data.c (revision 247809)
+++ data.c (working copy)
@@ -539,6 +539,7 @@ gfc_advance_section (mpz_t *section_index, gfc_arr
mpz_t tmp;
bool forwards;
int cmp;
+ gfc_expr *start, *end, *stride;
for (i = 0; i < ar->dimen; i++)
{
@@ -547,12 +548,16 @@ gfc_advance_section (mpz_t *section_index, gfc_arr
if (ar->stride[i])
{
+ stride = gfc_copy_expr(ar->stride[i]);
+ if(!gfc_simplify_expr(stride, 1))
+ gfc_internal_error("Simplification error");
mpz_add (section_index[i], section_index[i],
- ar->stride[i]->value.integer);
- if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
- forwards = true;
- else
- forwards = false;
+ stride->value.integer);
+ if (mpz_cmp_si (stride->value.integer, 0) >= 0)
+ forwards = true;
+ else
+ forwards = false;
+ gfc_free_expr(stride);
}
else
{
@@ -561,7 +566,13 @@ gfc_advance_section (mpz_t *section_index, gfc_arr
}
if (ar->end[i])
- cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
+{
+ end = gfc_copy_expr(ar->end[i]);
+ if(!gfc_simplify_expr(end, 1))
+ gfc_internal_error("Simplification error");
+ cmp = mpz_cmp (section_index[i], end->value.integer);
+ gfc_free_expr(end);
+ }
else
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
@@ -569,7 +580,13 @@ gfc_advance_section (mpz_t *section_index, gfc_arr
{
/* Reset index to start, then loop to advance the next index. */
if (ar->start[i])
- mpz_set (section_index[i], ar->start[i]->value.integer);
+ {
+ start = gfc_copy_expr(ar->start[i]);
+ if(!gfc_simplify_expr(start, 1))
+ gfc_internal_error("Simplification error");
+ mpz_set (section_index[i], start->value.integer);
+ gfc_free_expr(start);
+ }
else
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
}
@@ -679,6 +696,7 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *s
int i;
mpz_t delta;
mpz_t tmp;
+ gfc_expr *start;
mpz_set_si (*offset, 0);
mpz_init (tmp);
@@ -692,11 +710,15 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *s
case DIMEN_RANGE:
if (ar->start[i])
{
- mpz_sub (tmp, ar->start[i]->value.integer,
+ start = gfc_copy_expr(ar->start[i]);
+ if(!gfc_simplify_expr(start, 1))
+ gfc_internal_error("Simplification error");
+ mpz_sub (tmp, start->value.integer,
ar->as->lower[i]->value.integer);
mpz_mul (tmp, tmp, delta);
mpz_add (*offset, tmp, *offset);
- mpz_set (section_index[i], ar->start[i]->value.integer);
+ mpz_set (section_index[i], start->value.integer);
+ gfc_fr
Re: [Patch, fortran] PR80442 Handle DATA statement with iteration var in array slice
Ping
Also, attached is a better test case.
On 05/09/2017 10:49 PM, Nicolas Koenig wrote:
Hello everyone,
since everybody seems to be submitting patches the last few days, I
thought I might as well :)
Attached is a patch that makes the compiler capable of dealing with
implied do variables in
array slices in data statements.
The copying of the expressions is necessary since
gfc_simplify_expr(expr, 1) substitutes every
symbol in expr that is on the iter_stack with its value.
Ok for trunk?
Nicolas
Regression tested for x86_64-pc-linux-gnu.
Changelog:
2017-05-09 Nicolas Koenig
PR fortran/80442
* array.c (gfc_ref_dimen_size): Simplify stride
expression
* data.c (gfc_advance_section): Simplify start,
end and stride expressions
(gfc_advance_section): Simplify start and end
expressions
(gfc_get_section_index): Simplify start expression
2017-05-09 Nicolas Koenig
PR fortran/80442
* gfortran.dg/impl_do_var_data.f90: New Test
! { dg-do run }
! PR 80442
! This test case used to produce an bogus error
! about the variables being below the lower
! array bounds
program main
implicit none
integer:: i
integer, dimension(3):: A
data (A(i:i+2:i+1), i=1,2) /1, 2, 3/
if(any(A .ne. [1,3,2])) call abort()
end program
Index: array.c
===
--- array.c (revision 247809)
+++ array.c (working copy)
@@ -2201,6 +2201,7 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen,
mpz_t upper, lower, stride;
mpz_t diff;
bool t;
+ gfc_expr *stride_expr = NULL;
if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
@@ -2225,12 +2226,16 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen,
mpz_set_ui (stride, 1);
else
{
- if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
+ stride_expr = gfc_copy_expr(ar->stride[dimen]);
+ if(!gfc_simplify_expr(stride_expr, 1))
+ gfc_internal_error("Simplification error");
+ if (stride_expr->expr_type != EXPR_CONSTANT)
{
mpz_clear (stride);
return false;
}
- mpz_set (stride, ar->stride[dimen]->value.integer);
+ mpz_set (stride, stride_expr->value.integer);
+ gfc_free_expr(stride_expr);
}
/* Calculate the number of elements via gfc_dep_differce, but only if
Index: data.c
===
--- data.c (revision 247809)
+++ data.c (working copy)
@@ -539,6 +539,7 @@ gfc_advance_section (mpz_t *section_index, gfc_arr
mpz_t tmp;
bool forwards;
int cmp;
+ gfc_expr *start, *end, *stride;
for (i = 0; i < ar->dimen; i++)
{
@@ -547,12 +548,16 @@ gfc_advance_section (mpz_t *section_index, gfc_arr
if (ar->stride[i])
{
+ stride = gfc_copy_expr(ar->stride[i]);
+ if(!gfc_simplify_expr(stride, 1))
+ gfc_internal_error("Simplification error");
mpz_add (section_index[i], section_index[i],
- ar->stride[i]->value.integer);
- if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
- forwards = true;
- else
- forwards = false;
+ stride->value.integer);
+ if (mpz_cmp_si (stride->value.integer, 0) >= 0)
+ forwards = true;
+ else
+ forwards = false;
+ gfc_free_expr(stride);
}
else
{
@@ -561,7 +566,13 @@ gfc_advance_section (mpz_t *section_index, gfc_arr
}
if (ar->end[i])
- cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
+{
+ end = gfc_copy_expr(ar->end[i]);
+ if(!gfc_simplify_expr(end, 1))
+ gfc_internal_error("Simplification error");
+ cmp = mpz_cmp (section_index[i], end->value.integer);
+ gfc_free_expr(end);
+ }
else
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
@@ -569,7 +580,13 @@ gfc_advance_section (mpz_t *section_index, gfc_arr
{
/* Reset index to start, then loop to advance the next index. */
if (ar->start[i])
- mpz_set (section_index[i], ar->start[i]->value.integer);
+ {
+ start = gfc_copy_expr(ar->start[i]);
+ if(!gfc_simplify_expr(start, 1))
+ gfc_internal_error("Simplification error");
+ mpz_set (section_index[i], start->value.integer);
+ gfc_free_expr(start);
+ }
else
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
}
@@ -679,6 +696,7 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *s
int i;
mpz_t delta;
mpz_t tmp;
+ gfc_expr *start;
mpz_set_si (*offset, 0);
mpz_init (tmp);
@@ -692,11 +710,15 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *s
case DIMEN_RANGE:
if (ar->start[i])
{
- mpz_sub (tmp, ar->start[i]->value.integer,
+ start = gfc_copy_expr(ar->start[i]);
+ if(!gfc_simplify_ex
Re: [Patch, fortran] PR80442 Handle DATA statement with iteration var in array slice
Hello Jerry, Thanks for the review. Committed as r248012. Nicolas On 05/13/2017 06:30 PM, Jerry DeLisle wrote: On 05/13/2017 04:56 AM, Nicolas Koenig wrote: Ping Also, attached is a better test case. On 05/09/2017 10:49 PM, Nicolas Koenig wrote: Hello everyone, since everybody seems to be submitting patches the last few days, I thought I might as well :) Attached is a patch that makes the compiler capable of dealing with implied do variables in array slices in data statements. The copying of the expressions is necessary since gfc_simplify_expr(expr, 1) substitutes every symbol in expr that is on the iter_stack with its value. Ok for trunk? It looks OK and thanks for patch. Jerry Nicolas Regression tested for x86_64-pc-linux-gnu. Changelog: 2017-05-09 Nicolas Koenig PR fortran/80442 * array.c (gfc_ref_dimen_size): Simplify stride expression * data.c (gfc_advance_section): Simplify start, end and stride expressions (gfc_advance_section): Simplify start and end expressions (gfc_get_section_index): Simplify start expression 2017-05-09 Nicolas Koenig PR fortran/80442 * gfortran.dg/impl_do_var_data.f90: New Test
[Patch, fortran] PR35339 Optimize implied do loops in io statements
Hello everyone,
attached is a patch to simplify implied do loops in io statements by
replacing them with their respective array slices. For example "WRITE
(*,*) (a(i), i=1,4,2)" becomes "WRITE (*,*) a(1:4:2)".
Ok for trunk?
Nicolas
Regression tested for x85_64-pc-linux-gnu.
Changelog:
2017-05-27 Nicolas Koenig
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
PR fortran/35339
* gfortran.dg/implied_do_io_1.f90: New Test.
Index: frontend-passes.c
===
--- frontend-passes.c (revision 248539)
+++ frontend-passes.c (working copy)
@@ -1060,6 +1060,258 @@ convert_elseif (gfc_code **c, int *walk_subtrees A
return 0;
}
+#define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
+
+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);
+
+ if (curr->expr1->symtree->n.sym->attr.allocatable)
+return false;
+
+ ref = curr->expr1->ref;
+ if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0)
+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);
+ __attribute__((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_
Re: [Patch, fortran] PR35339 Optimize implied do loops in io statements
Hello Dominique,
mea culpa, their was a bit confusion with the file being open in emacs
and vi at the same time. Attached is the new patch with the #define removed.
Nicolas
On 05/29/2017 05:32 PM, Dominique d'Humières wrote:
Hi Nicolas,
Updating gfortran with your patch fails with
../../work/gcc/fortran/frontend-passes.c: In function 'bool
traverse_io_block(gfc_code*, bool*, gfc_code*)':
../../work/gcc/fortran/frontend-passes.c:1067:20: error: expected
unqualified-id before '(' token
#define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
^
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro
'swap'
std::swap(start->value.op.op1, start->value.op.op2);
^~~~
../../work/gcc/fortran/frontend-passes.c:1067:36: error: invalid operands of
types 'gfc_expr*' and 'gfc_expr*' to binary 'operator^'
#define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
^~
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro
'swap'
std::swap(start->value.op.op1, start->value.op.op2);
^~~~
../../work/gcc/fortran/frontend-passes.c:1067:41: error: in evaluation of
'operator^=(struct gfc_expr*, struct gfc_expr*)'
#define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
^
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro
'swap'
std::swap(start->value.op.op1, start->value.op.op2);
^~~~
../../work/gcc/fortran/frontend-passes.c:1067:48: error: invalid operands of
types 'gfc_expr*' and 'gfc_expr*' to binary 'operator^'
#define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
^~
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro
'swap'
std::swap(start->value.op.op1, start->value.op.op2);
^~~~
../../work/gcc/fortran/frontend-passes.c:1067:53: error: in evaluation of
'operator^=(struct gfc_expr*, struct gfc_expr*)'
#define swap(x, y) (x) ^= (y), (y) ^= (x), (x) ^= (y);
^
../../work/gcc/fortran/frontend-passes.c:1180:15: note: in expansion of macro
'swap'
std::swap(start->value.op.op1, start->value.op.op2);
^~~~
TIA
Dominique
Index: frontend-passes.c
===
--- frontend-passes.c (revision 248539)
+++ frontend-passes.c (working copy)
@@ -1060,6 +1060,256 @@ 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);
+
+ if (curr->expr1->symtree->n.sym->attr.allocatable)
+return false;
+
+ ref = curr->expr1->ref;
+ if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0)
+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 fa
Re: [Patch, fortran] PR35339 Optimize implied do loops in io statements
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
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
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 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=1,6,1)
end
gives an ICE.
TIA
Dominique
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->e
Re: [Patch, fortran] PR35339 Optimize implied do loops in io statements
Hello everyone,
here is a version of the patch that includes a workaround for PR 80960.
I have also included a separate test case for the failure that Dominique
detected. The style issues should be fixed.
Regression-tested. OK for trunk?
Nicolas
Changelog:
2017-06-03 Nicolas Koenig
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-06-03 Nicolas Koenig
PR fortran/35339
* gfortran.dg/implied_do_io_1.f90: New Test.
* gfortran.dg/implied_do_io_2.f90: New Test.
Index: frontend-passes.c
===
--- frontend-passes.c (Revision 248553)
+++ frontend-passes.c (Arbeitskopie)
@@ -1064,6 +1064,263 @@ 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;
+
+/* Recursively traverse the block of a WRITE or READ statement, and maybe
+ optimize 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];
+ gfc_expr *e;
+
+ /* 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);
+
+ /* FIXME: Workaround for PR 80945 - array slices with deferred character
+ lenghts do not work. Remove this section when the PR is fixed. */
+ e = curr->expr1;
+ if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
+ && e->ts.deferred)
+return false;
+ /* End of section to be removed. */
+
+ ref = e->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_
Re: [Patch, fortran] PR35339 Optimize implied do loops in io statements
With all the style fixes committed as r248877. Thanks for the review. Nicolas On 06/03/2017 06:25 PM, Jerry DeLisle wrote: On 06/03/2017 06:48 AM, Nicolas Koenig wrote: Hello everyone, here is a version of the patch that includes a workaround for PR 80960. I have also included a separate test case for the failure that Dominique detected. The style issues should be fixed. Regression-tested. OK for trunk? Yes, OK. Thanks for the work. Jerry
[Patch, fortran] PR69498 Fixing ICE with double free on symbol
Hello everyone,
a one-line-fix for one of the test cases in pr69498. The refs count of
the ppr@ symbol wasn't set properly. Attached are the patch & the test case.
If I understand the 'Write Access' page correctly, this would be the
kind of patch I would not have to bother the mailing list with but
instead could commit directly? Would this count as an "obvious fix"?
Nicolas
Regression tested for x86_64-pc-linux-gnu.
2017-03-18 Nicolas Koenig
PR fortran/69498
* decl.c (add_hidden_procptr_result): Fixed Refs count
of the created "ppr@" symbol.
2017-03-18 Nicolas Koenig
PR fortran/69498
* gfortran.dg/unexp_attribute.f90: New test
! { dg-do compile }
! This test used to result in an internal compiler error
function f()
interface
external f ! { dg-error "Unexpected attribute declaration statement in INTERFACE" }
end interface
end function
Index: decl.c
===
--- decl.c (revision 246260)
+++ decl.c (working copy)
@@ -5430,6 +5430,7 @@ add_hidden_procptr_result (gfc_symbol *sym)
gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
st2->n.sym = stree->n.sym;
+ stree->n.sym->refs++;
}
sym->result = stree->n.sym;
[Patch, fortran] PR69498 Fix ICE on unexpected submodule
Hello everyone,
this fixes the ICE. The problem was a discrepancy between the name of
the submodules symbol and the name of its symtree node.
Nicolas
2017-03-18 Nicolas Koenig
PR fortran/69498
* symbol.c (gfc_delete_symtree): If there is a period
in the name, ignore
everything before it.
2017-03-18 Nicolas Koenig
PR fortran/69498
* gfortran.dg/submodule_unexp.f90: New test
Index: symbol.c
===
--- symbol.c (Revision 246320)
+++ symbol.c (Arbeitskopie)
@@ -2782,10 +2782,20 @@ void
gfc_delete_symtree (gfc_symtree **root, const char *name)
{
gfc_symtree st, *st0;
+ const char *p;
- st0 = gfc_find_symtree (*root, name);
+ /* Submodules are marked as mod.submod. When freeing a submodule
+ symbol, the symtree only has "submod", so adjust that here. */
- st.name = gfc_get_string ("%s", name);
+ p = strchr(name, '.');
+ if (p)
+p++;
+ else
+p = name;
+
+ st0 = gfc_find_symtree (*root, p);
+
+ st.name = gfc_get_string ("%s", p);
gfc_delete_bbt (root, &st, compare_symtree);
free (st0);
! { dg-do compile }
! PR fortran/69498
! This used to ICE
program p
type t
submodule (m) sm ! { dg-error "Unexpected SUBMODULE statement at" }
end type
end
[Patch, fortran] PR69498 ICE on unexpected Submodule
Hello everyone,
Dominique send me this patch written by Paul some time ago. For some
reason it was never committed, so here we go :)
Ok for trunk?
Nicolas
Regression tested for x86_64-pc-linux-gnu.
Changelog:
2017-03-18 Nicolas Koenig
PR fortran/69498
* module.c (gfc_match_submodule): Add error
if function is called in the wrong state.
2017-03-18 Nicolas Koenig
PR fortran/69498
* gfortran.dg/submodule_unexp.f90: Modified test
to account for new error.
Index: gcc/fortran/module.c
===
--- gcc/fortran/module.c (revision 246743)
+++ gcc/fortran/module.c (working copy)
@@ -741,6 +741,13 @@ gfc_match_submodule (void)
if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C"))
return MATCH_ERROR;
+ if (gfc_current_state () != COMP_NONE)
+{
+ gfc_error ("SUBMODULE declaration at %C cannot appear within "
+ "another scoping unit");
+ return MATCH_ERROR;
+}
+
gfc_new_block = NULL;
gcc_assert (module_list == NULL);
Index: gcc/testsuite/gfortran.dg/submodule_unexp.f90
===
--- gcc/testsuite/gfortran.dg/submodule_unexp.f90 (revision 246743)
+++ gcc/testsuite/gfortran.dg/submodule_unexp.f90 (working copy)
@@ -3,6 +3,6 @@
! This used to ICE
program p
type t
- submodule (m) sm ! { dg-error "Unexpected SUBMODULE statement at" }
+ submodule (m) sm ! { dg-error "SUBMODULE declaration at" }
end type
end
Re: [Patch, fortran] PR69498 ICE on unexpected Submodule
Hello again,
I forgot to add the test case this patch fixes and to give Paul the
credit. Attached the new test case.
Nicolas
New & improved changelog:
2017-04-10 Nicolas Koenig
Paul Thomas
PR fortran/69498
* module.c (gfc_match_submodule): Add error
if function is called in the wrong state.
2017-04-10 Nicolas Koenig
PR fortran/69498
* gfortran.dg/submodule_unexp.f90: Modified test
to account for new error.
* gfortran.dg/submodule_twice.f90: New Test
On 04/10/2017 06:53 PM, Nicolas Koenig wrote:
Hello everyone,
Dominique send me this patch written by Paul some time ago. For some
reason it was never committed, so here we go :)
Ok for trunk?
Nicolas
Regression tested for x86_64-pc-linux-gnu.
Changelog:
2017-03-18 Nicolas Koenig
PR fortran/69498
* module.c (gfc_match_submodule): Add error
if function is called in the wrong state.
2017-03-18 Nicolas Koenig
PR fortran/69498
* gfortran.dg/submodule_unexp.f90: Modified test
to account for new error.
! { dg-do compile }
! PR fortran/69498
! This used to ICE
program main
submodule (m) sm ! { dg-error "SUBMODULE declaration at" }
submodule (m2) sm2 ! { dg-error "SUBMODULE declaration at" }
end program
Re: [Patch, fortran] PR69498 ICE on unexpected Submodule
Hello Paul, I would argue that this is but an elaborate plan to teach a newbie the ways of the bugzilla and enable him to properly close his first bug ;) Anyway, committed as r246826. Thanks for the review. Nicolas On 04/10/2017 08:07 PM, Paul Richard Thomas wrote: Dear Nicolas, The reasons are (i) moving country and (ii) the daytime job :-) I think that in the circumstances somebody else should OK the patch, although I think that it is perfect in every way possible. Actually, perhaps it is sufficiently obvious that I would and should have committed it - OK for trunk. Thanks Paul On 10 April 2017 at 17:53, Nicolas Koenig wrote: Hello everyone, Dominique send me this patch written by Paul some time ago. For some reason it was never committed, so here we go :) Ok for trunk? Nicolas Regression tested for x86_64-pc-linux-gnu. Changelog: 2017-03-18 Nicolas Koenig PR fortran/69498 * module.c (gfc_match_submodule): Add error if function is called in the wrong state. 2017-03-18 Nicolas Koenig PR fortran/69498 * gfortran.dg/submodule_unexp.f90: Modified test to account for new error.
[patch, fortran] PR39239 reject BIND(C) in EQUIVALENCE
Hello everyone,
this is my first attempt at a patch. The necessary paperwork for me to
contribute is all said & done. I'm looking forward to some more compiler
hacking :)
Nicolas
Here is the changelog:
2017-03-12 Nicolas Koenig
PR fortran/39239
* resolve.c (resolve_equivalence): report an error if
an equivalence variable is BIND(C).
2017-03-12 Nicolas Koenig
PR fortran/39239
* gfortran.dg/equiv_constraint_bind_c.f90: New test.
Index: resolve.c
===
--- resolve.c (revision 246070)
+++ resolve.c (working copy)
@@ -15675,6 +15675,13 @@ resolve_equivalence (gfc_equiv *eq)
&& !resolve_equivalence_derived (e->ts.u.derived, sym, e))
continue;
+ if (sym->attr.is_bind_c)
+ {
+ gfc_error ("EQUIVALENCE object %qs at %L cannot be C interop",
+ sym->name, &e->where);
+ continue;
+ }
+
/* Check that the types correspond correctly:
Note 5.28:
A numeric sequence structure may be equivalenced to another sequence
! Testcase for using EQUIVALENCE with BIND(C)
! See PR fortran/39239
! { dg-do compile }
module m
use iso_c_binding
implicit none
integer(c_int) :: i1, i2
bind(C) :: i2
equivalence(i1,i2) ! { dg-error "cannot be C interop" }
end module m
[patch, fortran] PR39239 Warning about EQUIVALENCE and VOLATILE
Hello everyone,
a simple patch to throw a warning if not all and not none of the
equivalence objects are volatile. (And the according modification of
gfortran.dg/volatile11.f90)
Nicolas
Regression tested for:
GNU Fortran (GCC) 7.0.1 20170311 (experimental)
Changelog:
2017-03-13 Nicolas Koenig
PR fortran/39239
* resolve.c (resolve_equivalence): Warn if not either
none or all equivalence objects are volatile
* gfortran.dg/volatile11.f90: Changed test to test for
the new warning
Index: fortran/resolve.c
===
--- fortran/resolve.c (revision 246070)
+++ fortran/resolve.c (working copy)
@@ -15560,7 +15560,7 @@ resolve_equivalence (gfc_equiv *eq)
locus *last_where = NULL;
seq_type eq_type, last_eq_type;
gfc_typespec *last_ts;
- int object, cnt_protected;
+ int object, cnt_protected, cnt_volatile;
const char *msg;
last_ts = &eq->expr->symtree->n.sym->ts;
@@ -15569,6 +15569,8 @@ resolve_equivalence (gfc_equiv *eq)
cnt_protected = 0;
+ cnt_volatile = 0;
+
for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
@@ -15641,6 +15643,17 @@ resolve_equivalence (gfc_equiv *eq)
sym = e->symtree->n.sym;
+ if(sym->attr.volatile_)
+cnt_volatile++;
+ if(cnt_volatile > 0 && cnt_volatile != object)
+ {
+ gfc_warning (0, "Either all or none of the objects in "
+ "the EQUIVALENCE set at %L shall have the "
+ "VOLATILE attribute",
+ &e->where);
+ break;
+ }
+
if (sym->attr.is_protected)
cnt_protected++;
if (cnt_protected > 0 && cnt_protected != object)
Index: testsuite/gfortran.dg/volatile11.f90
===
--- testsuite/gfortran.dg/volatile11.f90 (revision 246070)
+++ testsuite/gfortran.dg/volatile11.f90 (working copy)
@@ -1,8 +1,9 @@
! { dg-do compile }
-! { dg-options "-O2 -fdump-tree-optimized" }
+! { dg-options "-Wall -O2 -fdump-tree-optimized" }
! Tests that volatile can be applied to members of common blocks or
! equivalence groups (PR fortran/35037)
!
+
subroutine wait1
logical event
volatile event
@@ -14,26 +15,10 @@ subroutine wait1
end subroutine
subroutine wait2
- logical event, foo
- volatile event
- equivalence (event, foo)
- event = .false.
- do
-if (event) print *, 'NotOptimizedAway2'
- end do
-end subroutine
-
-subroutine wait3
logical event
integer foo
volatile foo
- equivalence (event, foo)
- event = .false.
- do
-if (event) print *, 'IsOptimizedAway'
- end do
+ equivalence (event, foo) ! { dg-warning "in the EQUIVALENCE set" }
end subroutine
! { dg-final { scan-tree-dump "NotOptimizedAway1" "optimized" } } */
-! { dg-final { scan-tree-dump "NotOptimizedAway2" "optimized" } } */
-! { dg-final { scan-tree-dump-not "IsOptimizedAway" "optimized" } } */
Re: [patch, fortran] PR39239 Warning about EQUIVALENCE and VOLATILE
On 03/14/2017 10:42 PM, Jerry DeLisle wrote:
On 03/14/2017 01:17 PM, Nicolas Koenig wrote:
Hello everyone,
a simple patch to throw a warning if not all and not none of the equivalence
objects are volatile. (And the according modification of
gfortran.dg/volatile11.f90)
Nicolas
Regression tested for:
GNU Fortran (GCC) 7.0.1 20170311 (experimental)
Changelog:
2017-03-13 Nicolas Koenig
PR fortran/39239
* resolve.c (resolve_equivalence): Warn if not either none or
all equivalence objects are volatile
* gfortran.dg/volatile11.f90: Changed test to test for the new
warning
Hi Nicolas,
Thanks for starting in on this.
Since this results in a warning, maybe change the wording from 'shall' to
should.
I did not dig into the Fortran Standards so I assume it need not be an error.
Also when you submit a patch, please also let us know what platform you
regression tested on, such as x86-64-linux, or Windows, or similar. (You can get
the whole string from subdirectory names in build directory. On mine its
x86_64-pc-linux-gnu) Sometimes we accidentally break things on different
platforms. so this way we can see it tested ok over here and seems to fail over
there.
Your patch has changed some of the scan dumps and I am wondering if you have
deleted something we use to check for?
Jerry
Hello Jerry,
I have to thank for the kind feedback.
Attached is a reworked version of the patch with the changes applied. It
also should have the same scan dump now, one of the test cases was
edited stupidly.
The regression tests for both the old as well as the new test have been
performed on an x86-64-linux (x86_64-pc-linux-gnu).
Nicolas
Index: fortran/resolve.c
===
--- fortran/resolve.c (revision 246143)
+++ fortran/resolve.c (working copy)
@@ -15560,7 +15560,7 @@ resolve_equivalence (gfc_equiv *eq)
locus *last_where = NULL;
seq_type eq_type, last_eq_type;
gfc_typespec *last_ts;
- int object, cnt_protected;
+ int object, cnt_protected, cnt_volatile;
const char *msg;
last_ts = &eq->expr->symtree->n.sym->ts;
@@ -15569,6 +15569,8 @@ resolve_equivalence (gfc_equiv *eq)
cnt_protected = 0;
+ cnt_volatile = 0;
+
for (object = 1; eq; eq = eq->eq, object++)
{
e = eq->expr;
@@ -15641,6 +15643,17 @@ resolve_equivalence (gfc_equiv *eq)
sym = e->symtree->n.sym;
+ if(sym->attr.volatile_)
+cnt_volatile++;
+ if(cnt_volatile > 0 && cnt_volatile != object)
+ {
+ gfc_warning (0, "Either all or none of the objects in "
+ "the EQUIVALENCE set at %L should have the "
+ "VOLATILE attribute",
+ &e->where);
+ break;
+ }
+
if (sym->attr.is_protected)
cnt_protected++;
if (cnt_protected > 0 && cnt_protected != object)
Index: testsuite/gfortran.dg/volatile11.f90
===
--- testsuite/gfortran.dg/volatile11.f90 (revision 246140)
+++ testsuite/gfortran.dg/volatile11.f90 (working copy)
@@ -3,6 +3,7 @@
! Tests that volatile can be applied to members of common blocks or
! equivalence groups (PR fortran/35037)
!
+
subroutine wait1
logical event
volatile event
@@ -16,7 +17,7 @@ end subroutine
subroutine wait2
logical event, foo
volatile event
- equivalence (event, foo)
+ equivalence (event, foo) ! { dg-warning "in the EQUIVALENCE set" }
event = .false.
do
if (event) print *, 'NotOptimizedAway2'
@@ -27,7 +28,7 @@ subroutine wait3
logical event
integer foo
volatile foo
- equivalence (event, foo)
+ equivalence (event, foo) ! { dg-warning "in the EQUIVALENCE set" }
event = .false.
do
if (event) print *, 'IsOptimizedAway'
[Patch, fortran] PR39239 EQUIVALENCE and BIND(C)
Hello everyone,
I submitted this patch a week ago, but I think it got lost. It adds an
error if BIND(C) is used with EQUIVALENCE.
Nicolas
Regression tested for x86_64-pc-linux-gnu.
2017-03-18 Nicolas Koenig
PR fortran/39239
* resolve.c (resolve_equivalence): report an error if
an equivalence variable is BIND(C).
2017-03-18 Nicolas Koenig
PR fortran/39239
* gfortran.dg/equiv_constraint_bind_c.f90: New test.
Index: resolve.c
===
--- resolve.c (revision 246070)
+++ resolve.c (working copy)
@@ -15675,6 +15675,13 @@ resolve_equivalence (gfc_equiv *eq)
&& !resolve_equivalence_derived (e->ts.u.derived, sym, e))
continue;
+ if (sym->attr.is_bind_c)
+ {
+ gfc_error ("EQUIVALENCE object %qs at %L cannot be BIND(C)",
+ sym->name, &e->where);
+ continue;
+ }
+
/* Check that the types correspond correctly:
Note 5.28:
A numeric sequence structure may be equivalenced to another sequence
! Testcase for using EQUIVALENCE with BIND(C)
! See PR fortran/39239
! { dg-do compile }
module m
use iso_c_binding
implicit none
integer(c_int) :: i1, i2
bind(C) :: i2
equivalence(i1,i2) ! { dg-error "cannot be BIND" }
end module m
