From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 35615 invoked by alias); 2 Aug 2018 11:35:33 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 35571 invoked by uid 89); 2 Aug 2018 11:35:32 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.8 required=5.0 tests=AWL,BAYES_00,GIT_PATCH_1,GIT_PATCH_2,GIT_PATCH_3,KAM_ASCII_DIVIDERS,KAM_LAZY_DOMAIN_SECURITY,LIKELY_SPAM_FROM autolearn=ham version=3.3.2 spammy=liable, jerry, UNIT, Jerry X-HELO: edge10.ethz.ch Received: from edge10.ethz.ch (HELO edge10.ethz.ch) (82.130.75.186) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 02 Aug 2018 11:35:25 +0000 Received: from mailm211.d.ethz.ch (129.132.139.35) by edge10.ethz.ch (82.130.75.186) with Microsoft SMTP Server (TLS) id 14.3.408.0; Thu, 2 Aug 2018 13:31:31 +0200 Received: from student.ethz.ch (92.18.139.120) by mailm211.d.ethz.ch (2001:67c:10ec:5603::25) with Microsoft SMTP Server (version=TLS1_2, cipher=TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256) id 15.1.1415.2; Thu, 2 Aug 2018 13:31:38 +0200 Date: Thu, 02 Aug 2018 11:35:00 -0000 From: Nicolas Koenig To: "Andre Vieira (lists)" , CC: , , Ulrich Weigand , , Subject: Async I/O patch with compilation fix Message-ID: <20180802113135.5qmwnfpxwv4dic6z@student.ethz.ch> References: <20180726133142.DE075D801C7@oc3748833570.ibm.com> <01cd923e-18c7-f745-a75d-49536d56cdbf@netcologne.de> <5B6021C0.5060507@arm.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="sdjvelw7zuufge36" Content-Disposition: inline In-Reply-To: <5B6021C0.5060507@arm.com> User-Agent: NeoMutt/20170113 (1.7.2) Return-Path: koenigni@student.ethz.ch X-SW-Source: 2018-08/txt/msg00180.txt.bz2 --sdjvelw7zuufge36 Content-Type: text/plain; charset="us-ascii" Content-Disposition: inline Content-length: 3902 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. --sdjvelw7zuufge36 Content-Type: text/x-diff; charset="us-ascii" Content-Disposition: attachment; filename="pa.diff" Content-length: 45529 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 another become visible to the * Files opened without an explicit ACTION= specifier:: * File operations on symbolic links:: * File format of unformatted sequential files:: +* Asynchronous I/O:: @end menu @@ -1486,6 +1486,20 @@ program main end program main @end smallexample +@node Asynchronous I/O +@section Asynchronous I/O +@cindex input/output, asynchronous +@cindex asynchronous I/O + +Asynchronous I/O is supported if the program is linked against the +POSIX thread library. If that is not the case, all I/O is performed +as synchronous. + +On some systems, such as Darwin or Solaris, the POSIX thread library +is always linked in, so asynchronous I/O is always performed. On other +sytems, such as Linux, it is necessary to specify @option{-pthread}, +@option{-lpthread} or @option{-fopenmp} during the linking step. + @c --------------------------------------------------------------------- @c Extensions @c --------------------------------------------------------------------- Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (revision 263244) +++ gcc/fortran/trans-decl.c (working copy) @@ -698,7 +698,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_EFFECTS (decl) = 1; Index: gcc/fortran/trans-io.c =================================================================== --- gcc/fortran/trans-io.c (revision 263244) +++ gcc/fortran/trans-io.c (working copy) @@ -438,10 +438,9 @@ gfc_build_io_library_fndecls (void) get_identifier (PREFIX("st_iolength")), ".w", void_type_node, 1, dt_parm_type); - /* TODO: Change when asynchronous I/O is implemented. */ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type); iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_wait")), ".X", + get_identifier (PREFIX("st_wait_async")), ".w", void_type_node, 1, parm_type); parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); @@ -1527,7 +1526,7 @@ gfc_trans_wait (gfc_code * code) mask |= IOPARM_common_err; if (p->id) - mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id); set_parameter_const (&block, var, IOPARM_common_flags, mask); Index: gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 (revision 263244) +++ gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 (working copy) @@ -7,10 +7,12 @@ logical :: vpending open(10, file='mydata_f2003_inquire_1', asynchronous="yes", blank="null", & & decimal="comma", encoding="utf-8", sign="plus") +write (10,*, asynchronous="yes", id=vid) 'asdf' +wait (10) + inquire(unit=10, round=sround, sign=ssign, size=vsize, id=vid, & & pending=vpending, asynchronous=sasynchronous, decimal=sdecimal, & & encoding=sencoding) - if (ssign.ne."PLUS") STOP 1 if (sasynchronous.ne."YES") STOP 2 if (sdecimal.ne."COMMA") STOP 3 Index: gcc/testsuite/gfortran.dg/f2003_io_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/f2003_io_1.f03 (revision 263244) +++ gcc/testsuite/gfortran.dg/f2003_io_1.f03 (working copy) @@ -13,6 +13,7 @@ open(10, file='mydata_f2003_io_1', asynchronous="y write(10,'(10f8.3)', asynchronous="yes", decimal="comma", id=j) a rewind(10) read(10,'(10f8.3)', asynchronous="yes", decimal="comma", blank="zero") b +wait(10) if (any(b.ne.23.45)) STOP 1 c = 3.14 @@ -24,6 +25,7 @@ rewind(10) write(10,'(10f8.3)', asynchronous="yes", decimal="point") a rewind(10) read(10,'(10f8.3)', asynchronous="yes", decimal="point") b +wait (10) if (any(b.ne.23.45)) STOP 3 wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=j) Index: libgfortran/Makefile.am =================================================================== --- libgfortran/Makefile.am (revision 263244) +++ libgfortran/Makefile.am (working copy) @@ -100,7 +100,8 @@ io/transfer128.c \ io/unit.c \ io/unix.c \ io/write.c \ -io/fbuf.c +io/fbuf.c \ +io/async.c endif @@ -108,7 +109,8 @@ gfor_io_headers= \ io/io.h \ io/fbuf.h \ io/format.h \ -io/unix.h +io/unix.h \ +io/async.h gfor_helper_src= \ intrinsics/associated.c \ Index: libgfortran/Makefile.in =================================================================== --- libgfortran/Makefile.in (revision 263244) +++ libgfortran/Makefile.in (working copy) @@ -70,7 +70,8 @@ target_triplet = @target@ @LIBGFOR_MINIMAL_FALSE@io/unit.c \ @LIBGFOR_MINIMAL_FALSE@io/unix.c \ @LIBGFOR_MINIMAL_FALSE@io/write.c \ -@LIBGFOR_MINIMAL_FALSE@io/fbuf.c +@LIBGFOR_MINIMAL_FALSE@io/fbuf.c \ +@LIBGFOR_MINIMAL_FALSE@io/async.c @LIBGFOR_MINIMAL_FALSE@am__append_3 = \ @LIBGFOR_MINIMAL_FALSE@intrinsics/access.c \ @@ -352,7 +353,7 @@ am__objects_47 = $(am__objects_4) $(am__objects_5) @LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \ @LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \ @LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \ -@LIBGFOR_MINIMAL_FALSE@ fbuf.lo +@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo am__objects_49 = size_from_kind.lo $(am__objects_48) @LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \ @LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \ @@ -650,7 +651,8 @@ gfor_io_headers = \ io/io.h \ io/fbuf.h \ io/format.h \ -io/unix.h +io/unix.h \ +io/async.h gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \ intrinsics/args.c intrinsics/cshift0.c intrinsics/eoshift0.c \ @@ -1551,6 +1553,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/async.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r16.Plo@am__quote@ @@ -5814,6 +5817,13 @@ fbuf.lo: io/fbuf.c @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fbuf.lo `test -f 'io/fbuf.c' || echo '$(srcdir)/'`io/fbuf.c +async.lo: io/async.c +@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT async.lo -MD -MP -MF $(DEPDIR)/async.Tpo -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c +@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/async.Tpo $(DEPDIR)/async.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='io/async.c' object='async.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o async.lo `test -f 'io/async.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/gfortran.map =================================================================== --- libgfortran/gfortran.map (revision 263244) +++ libgfortran/gfortran.map (working copy) @@ -1483,3 +1483,8 @@ GFORTRAN_C99_8 { y1f; ynf; }; + +GFORTRAN_9 { + global: + _gfortran_st_wait_async; +}; Index: libgfortran/io/close.c =================================================================== --- libgfortran/io/close.c (revision 263244) +++ libgfortran/io/close.c (working copy) @@ -24,6 +24,7 @@ see the files COPYING3 and COPYING.RUNTIME respect #include "io.h" #include "unix.h" +#include "async.h" #include typedef enum @@ -57,6 +58,15 @@ st_close (st_parameter_close *clp) find_option (&clp->common, clp->status, clp->status_len, status_opt, "Bad STATUS parameter in CLOSE statement"); + u = find_unit (clp->common.unit); + + if (ASYNC_IO && u && u->au) + if (async_wait (&(clp->common), u->au)) + { + library_end (); + return; + } + if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) { library_end (); @@ -63,7 +73,6 @@ st_close (st_parameter_close *clp) return; } - u = find_unit (clp->common.unit); if (u != NULL) { if (close_share (u) < 0) Index: libgfortran/io/file_pos.c =================================================================== --- libgfortran/io/file_pos.c (revision 263244) +++ libgfortran/io/file_pos.c (working copy) @@ -25,6 +25,7 @@ see the files COPYING3 and COPYING.RUNTIME respect #include "io.h" #include "fbuf.h" #include "unix.h" +#include "async.h" #include /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE, @@ -187,6 +188,7 @@ void st_backspace (st_parameter_filepos *fpp) { gfc_unit *u; + bool needs_unlock = false; library_start (&fpp->common); @@ -214,6 +216,17 @@ st_backspace (st_parameter_filepos *fpp) goto done; } + if (ASYNC_IO && u->au) + { + if (async_wait (&(fpp->common), u->au)) + return; + else + { + needs_unlock = true; + LOCK (&u->au->io_lock); + } + } + /* Make sure format buffer is flushed and reset. */ if (u->flags.form == FORM_FORMATTED) { @@ -267,8 +280,13 @@ st_backspace (st_parameter_filepos *fpp) done: if (u != NULL) - unlock_unit (u); + { + unlock_unit (u); + if (ASYNC_IO && u->au && needs_unlock) + UNLOCK (&u->au->io_lock); + } + library_end (); } @@ -280,6 +298,7 @@ void st_endfile (st_parameter_filepos *fpp) { gfc_unit *u; + bool needs_unlock = false; library_start (&fpp->common); @@ -294,6 +313,17 @@ st_endfile (st_parameter_filepos *fpp) goto done; } + if (ASYNC_IO && u->au) + { + if (async_wait (&(fpp->common), u->au)) + return; + else + { + needs_unlock = true; + LOCK (&u->au->io_lock); + } + } + if (u->flags.access == ACCESS_SEQUENTIAL && u->endfile == AFTER_ENDFILE) { @@ -376,9 +406,12 @@ st_endfile (st_parameter_filepos *fpp) } } - done: - unlock_unit (u); + done: + if (ASYNC_IO && u->au && needs_unlock) + UNLOCK (&u->au->io_lock); + unlock_unit (u); + library_end (); } @@ -390,6 +423,7 @@ void st_rewind (st_parameter_filepos *fpp) { gfc_unit *u; + bool needs_unlock = true; library_start (&fpp->common); @@ -401,6 +435,17 @@ st_rewind (st_parameter_filepos *fpp) "Cannot REWIND a file opened for DIRECT access"); else { + if (ASYNC_IO && u->au) + { + if (async_wait (&(fpp->common), u->au)) + return; + else + { + needs_unlock = true; + LOCK (&u->au->io_lock); + } + } + /* If there are previously written bytes from a write with ADVANCE="no", add a record marker before performing the ENDFILE. */ @@ -436,6 +481,10 @@ st_rewind (st_parameter_filepos *fpp) } /* Update position for INQUIRE. */ u->flags.position = POSITION_REWIND; + + if (ASYNC_IO && u->au && needs_unlock) + UNLOCK (&u->au->io_lock); + unlock_unit (u); } @@ -450,6 +499,7 @@ void st_flush (st_parameter_filepos *fpp) { gfc_unit *u; + bool needs_unlock = false; library_start (&fpp->common); @@ -456,6 +506,17 @@ st_flush (st_parameter_filepos *fpp) u = find_unit (fpp->common.unit); if (u != NULL) { + if (ASYNC_IO && u->au) + { + if (async_wait (&(fpp->common), u->au)) + return; + else + { + needs_unlock = true; + LOCK (&u->au->io_lock); + } + } + /* Make sure format buffer is flushed. */ if (u->flags.form == FORM_FORMATTED) fbuf_flush (u, u->mode); @@ -469,5 +530,8 @@ st_flush (st_parameter_filepos *fpp) generate_error (&fpp->common, LIBERROR_BAD_OPTION, "Specified UNIT in FLUSH is not connected"); + if (needs_unlock) + UNLOCK (&u->au->io_lock); + library_end (); } Index: libgfortran/io/inquire.c =================================================================== --- libgfortran/io/inquire.c (revision 263244) +++ libgfortran/io/inquire.c (working copy) @@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect /* Implement the non-IOLENGTH variant of the INQUIRY statement */ #include "io.h" +#include "async.h" #include "unix.h" #include @@ -281,12 +282,6 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u { GFC_INTEGER_4 cf2 = iqp->flags2; - if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0) - *iqp->pending = 0; - - if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0) - *iqp->id = 0; - if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0) { if (u == NULL || u->flags.form != FORM_FORMATTED) @@ -332,21 +327,43 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u if (u == NULL) p = undefined; else - switch (u->flags.async) { - case ASYNC_YES: - p = yes; - break; - case ASYNC_NO: - p = no; - break; - default: - internal_error (&iqp->common, "inquire_via_unit(): Bad async"); + switch (u->flags.async) + { + case ASYNC_YES: + p = yes; + break; + case ASYNC_NO: + p = no; + break; + default: + internal_error (&iqp->common, "inquire_via_unit(): Bad async"); + } } - cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p); } + if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0) + { + if (!ASYNC_IO || u->au == NULL) + *(iqp->pending) = 0; + else + { + LOCK (&(u->au->lock)); + if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0) + { + int id; + id = *(iqp->id); + *(iqp->pending) = id > u->au->id.low; + } + else + { + *(iqp->pending) = ! u->au->empty; + } + UNLOCK (&(u->au->lock)); + } + } + if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0) { if (u == NULL) Index: libgfortran/io/io.h =================================================================== --- libgfortran/io/io.h (revision 263244) +++ libgfortran/io/io.h (working copy) @@ -531,7 +531,9 @@ typedef struct st_parameter_dt /* A flag used to identify when a non-standard expanded namelist read has occurred. */ unsigned expanded_read : 1; - /* 13 unused bits. */ + /* Flag to indicate if the statement has async="YES". */ + unsigned async : 1; + /* 12 unused bits. */ int child_saved_iostat; int nml_delim; @@ -590,7 +592,7 @@ extern char check_st_parameter_dt[sizeof (((st_par typedef struct { st_parameter_common common; - CHARACTER1 (id); + GFC_INTEGER_4 *id; } st_parameter_wait; @@ -659,6 +661,9 @@ typedef struct gfc_unit int continued; + /* Contains the pointer to the async unit. */ + struct async_unit *au; + __gthread_mutex_t lock; /* Number of threads waiting to acquire this unit's lock. When non-zero, close_unit doesn't only removes the unit @@ -815,11 +820,18 @@ extern void next_record (st_parameter_dt *, int); internal_proto(next_record); extern void st_wait (st_parameter_wait *); -export_proto(st_wait); +export_proto (st_wait); +extern void st_wait_async (st_parameter_wait *); +export_proto (st_wait_async); + extern void hit_eof (st_parameter_dt *); internal_proto(hit_eof); +extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int, + gfc_charlen_type); +internal_proto (transfer_array_inner); + /* read.c */ extern void set_integer (void *, GFC_INTEGER_LARGEST, int); @@ -988,3 +1000,14 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k) #endif +extern void +st_write_done_worker (st_parameter_dt *); +internal_proto (st_write_done_worker); + +extern void +st_read_done_worker (st_parameter_dt *); +internal_proto (st_read_done_worker); + +extern void +data_transfer_init_worker (st_parameter_dt *, int); +internal_proto (data_transfer_init_worker); Index: libgfortran/io/open.c =================================================================== --- libgfortran/io/open.c (revision 263244) +++ libgfortran/io/open.c (working copy) @@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect #include "io.h" #include "fbuf.h" #include "unix.h" +#include "async.h" #ifdef HAVE_UNISTD_H #include @@ -651,8 +652,12 @@ new_unit (st_parameter_open *opp, gfc_unit *u, uni else u->fbuf = NULL; - - + /* Check if asynchrounous. */ + if (flags->async == ASYNC_YES) + init_async_unit (u); + else + u->au = NULL; + return u; cleanup: Index: libgfortran/io/read.c =================================================================== --- libgfortran/io/read.c (revision 263244) +++ libgfortran/io/read.c (working copy) @@ -30,6 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respect #include #include #include +#include "async.h" typedef unsigned char uchar; @@ -42,6 +43,7 @@ typedef unsigned char uchar; void set_integer (void *dest, GFC_INTEGER_LARGEST value, int length) { + NOTE ("set_integer: %lld %p", (long long int) value, dest); switch (length) { #ifdef HAVE_GFC_INTEGER_16 Index: libgfortran/io/transfer.c =================================================================== --- libgfortran/io/transfer.c (revision 263244) +++ libgfortran/io/transfer.c (working copy) @@ -31,6 +31,7 @@ see the files COPYING3 and COPYING.RUNTIME respect #include "fbuf.h" #include "format.h" #include "unix.h" +#include "async.h" #include #include @@ -184,6 +185,12 @@ static const st_option pad_opt[] = { {NULL, 0} }; +static const st_option async_opt[] = { + {"yes", ASYNC_YES}, + {"no", ASYNC_NO}, + {NULL, 0} +}; + typedef enum { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL, FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM @@ -1594,7 +1601,8 @@ formatted_transfer_scalar_read (st_parameter_dt *d read_f (dtp, f, p, kind); break; default: - internal_error (&dtp->common, "formatted_transfer(): Bad type"); + internal_error (&dtp->common, + "formatted_transfer (): Bad type"); } break; @@ -2066,7 +2074,7 @@ formatted_transfer_scalar_write (st_parameter_dt * break; default: internal_error (&dtp->common, - "formatted_transfer(): Bad type"); + "formatted_transfer (): Bad type"); } break; @@ -2281,7 +2289,39 @@ formatted_transfer (st_parameter_dt *dtp, bt type, } } +/* Wrapper function for I/O of scalar types. If this should be an async I/O + request, queue it. For a synchronous write on an async unit, perform the + wait operation and return an error. For all synchronous writes, call the + right transfer function. */ +static void +wrap_scalar_transfer (st_parameter_dt *dtp, bt type, void *p, int kind, + size_t size, size_t n_elem) +{ + if (dtp->u.p.current_unit && dtp->u.p.current_unit->au) + { + if (dtp->u.p.async) + { + transfer_args args; + args.scalar.transfer = dtp->u.p.transfer; + args.scalar.arg_bt = type; + args.scalar.data = p; + args.scalar.i = kind; + args.scalar.s1 = size; + args.scalar.s2 = n_elem; + enqueue_transfer (dtp->u.p.current_unit->au, &args, + AIO_TRANSFER_SCALAR); + return; + } + } + /* Come here if there was no asynchronous I/O to be scheduled. */ + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) + return; + + dtp->u.p.transfer (dtp, type, p, kind, size, 1); +} + + /* Data transfer entry points. The type of the data entity is implicit in the subroutine call. This prevents us from having to share a common enum with the compiler. */ @@ -2289,9 +2329,7 @@ formatted_transfer (st_parameter_dt *dtp, bt type, void transfer_integer (st_parameter_dt *dtp, void *p, int kind) { - if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) - return; - dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1); + wrap_scalar_transfer (dtp, BT_INTEGER, p, kind, kind, 1); } void @@ -2307,7 +2345,7 @@ transfer_real (st_parameter_dt *dtp, void *p, int if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; size = size_from_real_kind (kind); - dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1); + wrap_scalar_transfer (dtp, BT_REAL, p, kind, size, 1); } void @@ -2319,9 +2357,7 @@ transfer_real_write (st_parameter_dt *dtp, void *p void transfer_logical (st_parameter_dt *dtp, void *p, int kind) { - if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) - return; - dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1); + wrap_scalar_transfer (dtp, BT_LOGICAL, p, kind, kind, 1); } void @@ -2345,7 +2381,7 @@ transfer_character (st_parameter_dt *dtp, void *p, p = empty_string; /* Set kind here to 1. */ - dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1); + wrap_scalar_transfer (dtp, BT_CHARACTER, p, 1, len, 1); } void @@ -2369,7 +2405,7 @@ transfer_character_wide (st_parameter_dt *dtp, voi p = empty_string; /* Here we pass the actual kind value. */ - dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1); + wrap_scalar_transfer (dtp, BT_CHARACTER, p, kind, len, 1); } void @@ -2385,7 +2421,7 @@ transfer_complex (st_parameter_dt *dtp, void *p, i if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; size = size_from_complex_kind (kind); - dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1); + wrap_scalar_transfer (dtp, BT_COMPLEX, p, kind, size, 1); } void @@ -2395,8 +2431,8 @@ transfer_complex_write (st_parameter_dt *dtp, void } void -transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, - gfc_charlen_type charlen) +transfer_array_inner (st_parameter_dt *dtp, gfc_array_char *desc, int kind, + gfc_charlen_type charlen) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -2407,7 +2443,7 @@ void bt iotype; /* Adjust item_count before emitting error message. */ - + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; @@ -2471,6 +2507,36 @@ void } void +transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, + gfc_charlen_type charlen) +{ + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) + return; + + if (dtp->u.p.current_unit && dtp->u.p.current_unit->au) + { + if (dtp->u.p.async) + { + transfer_args args; + size_t sz = sizeof (gfc_array_char) + + sizeof (descriptor_dimension) + * GFC_DESCRIPTOR_RANK (desc); + args.array.desc = xmalloc (sz); + NOTE ("desc = %p", (void *) args.array.desc); + memcpy (args.array.desc, desc, sz); + args.array.kind = kind; + args.array.charlen = charlen; + enqueue_transfer (dtp->u.p.current_unit->au, &args, + AIO_TRANSFER_ARRAY); + return; + } + } + /* Come here if there was no asynchronous I/O to be scheduled. */ + transfer_array_inner (dtp, desc, kind, charlen); +} + + +void transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind, gfc_charlen_type charlen) { @@ -2492,7 +2558,7 @@ transfer_derived (st_parameter_dt *parent, void *d else parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc; } - parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1); + wrap_scalar_transfer (parent, BT_CLASS, dtio_source, 0, 0, 1); } @@ -2667,7 +2733,10 @@ data_transfer_init (st_parameter_dt *dtp, int read unit_flags u_flags; /* Used for creating a unit if needed. */ GFC_INTEGER_4 cf = dtp->common.flags; namelist_info *ionml; + async_unit *au; + NOTE ("data_transfer_init"); + ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL; memset (&dtp->u.p, 0, sizeof (dtp->u.p)); @@ -2693,9 +2762,9 @@ data_transfer_init (st_parameter_dt *dtp, int read } else if (dtp->u.p.current_unit->s == NULL) { /* Open the unit with some default flags. */ - st_parameter_open opp; - unit_convert conv; - + st_parameter_open opp; + unit_convert conv; + NOTE ("Open the unit with some default flags."); memset (&u_flags, '\0', sizeof (u_flags)); u_flags.access = ACCESS_SEQUENTIAL; u_flags.action = ACTION_READWRITE; @@ -2770,6 +2839,42 @@ data_transfer_init (st_parameter_dt *dtp, int read else if (dtp->u.p.current_unit->internal_unit_kind > 0) dtp->u.p.unit_is_internal = 1; + if ((cf & IOPARM_DT_HAS_ASYNCHRONOUS) != 0) + { + int f; + f = find_option (&dtp->common, dtp->asynchronous, dtp->asynchronous_len, + async_opt, "Bad ASYNCHRONOUS in data transfer " + "statement"); + if (f == ASYNC_YES && dtp->u.p.current_unit->flags.async != ASYNC_YES) + { + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, + "ASYNCHRONOUS transfer without " + "ASYHCRONOUS='YES' in OPEN"); + return; + } + dtp->u.p.async = f == ASYNC_YES; + } + + au = dtp->u.p.current_unit->au; + if (au) + { + if (dtp->u.p.async) + { + /* If this is an asynchronous I/O statement, collect errors and + return if there are any. */ + if (collect_async_errors (&dtp->common, au)) + return; + } + else + { + /* Synchronous statement: Perform a wait operation for any pending + asynchronous I/O. This needs to be done before all other error + checks. See F2008, 9.6.4.1. */ + if (async_wait (&(dtp->common), au)) + return; + } + } + /* Check the action. */ if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE) @@ -3009,6 +3114,57 @@ data_transfer_init (st_parameter_dt *dtp, int read if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED) dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad; + /* Set up the subroutine that will handle the transfers. */ + + if (read_flag) + { + if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) + dtp->u.p.transfer = unformatted_read; + else + { + if ((cf & IOPARM_DT_LIST_FORMAT) != 0) + dtp->u.p.transfer = list_formatted_read; + else + dtp->u.p.transfer = formatted_transfer; + } + } + else + { + if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) + dtp->u.p.transfer = unformatted_write; + else + { + if ((cf & IOPARM_DT_LIST_FORMAT) != 0) + dtp->u.p.transfer = list_formatted_write; + else + dtp->u.p.transfer = formatted_transfer; + } + } + + if (au) + { + NOTE ("enqueue_data_transfer"); + enqueue_data_transfer_init (au, dtp, read_flag); + } + else + { + NOTE ("invoking data_transfer_init_worker"); + data_transfer_init_worker (dtp, read_flag); + } +} + +void +data_transfer_init_worker (st_parameter_dt *dtp, int read_flag) +{ + GFC_INTEGER_4 cf = dtp->common.flags; + + NOTE ("starting worker..."); + + if (read_flag && dtp->u.p.current_unit->flags.form != FORM_UNFORMATTED + && ((cf & IOPARM_DT_LIST_FORMAT) != 0) + && dtp->u.p.current_unit->child_dtio == 0) + dtp->u.p.current_unit->last_char = EOF - 1; + /* Check to see if we might be reading what we wrote before */ if (dtp->u.p.mode != dtp->u.p.current_unit->mode @@ -3135,38 +3291,6 @@ data_transfer_init (st_parameter_dt *dtp, int read pre_position (dtp); - - /* Set up the subroutine that will handle the transfers. */ - - if (read_flag) - { - if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) - dtp->u.p.transfer = unformatted_read; - else - { - if ((cf & IOPARM_DT_LIST_FORMAT) != 0) - { - if (dtp->u.p.current_unit->child_dtio == 0) - dtp->u.p.current_unit->last_char = EOF - 1; - dtp->u.p.transfer = list_formatted_read; - } - else - dtp->u.p.transfer = formatted_transfer; - } - } - else - { - if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) - dtp->u.p.transfer = unformatted_write; - else - { - if ((cf & IOPARM_DT_LIST_FORMAT) != 0) - dtp->u.p.transfer = list_formatted_write; - else - dtp->u.p.transfer = formatted_transfer; - } - } - /* Make sure that we don't do a read after a nonadvancing write. */ if (read_flag) @@ -4099,7 +4223,7 @@ extern void st_read_done (st_parameter_dt *); export_proto(st_read_done); void -st_read_done (st_parameter_dt *dtp) +st_read_done_worker (st_parameter_dt *dtp) { finalize_transfer (dtp); @@ -4127,6 +4251,30 @@ void free_format_data (dtp->u.p.fmt); free_format (dtp); } + } +} + +void +st_read_done (st_parameter_dt *dtp) +{ + if (dtp->u.p.current_unit) + { + if (dtp->u.p.current_unit->au) + { + if (dtp->common.flags & IOPARM_DT_HAS_ID) + *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, AIO_READ_DONE); + else + { + enqueue_done (dtp->u.p.current_unit->au, AIO_READ_DONE); + /* An asynchronous unit without ASYNCHRONOUS="YES" - make this + synchronous by performing a wait operation. */ + if (!dtp->u.p.async) + async_wait (&dtp->common, dtp->u.p.current_unit->au); + } + } + else + st_read_done_worker (dtp); + unlock_unit (dtp->u.p.current_unit); } @@ -4134,7 +4282,7 @@ void } extern void st_write (st_parameter_dt *); -export_proto(st_write); +export_proto (st_write); void st_write (st_parameter_dt *dtp) @@ -4143,11 +4291,9 @@ st_write (st_parameter_dt *dtp) data_transfer_init (dtp, 0); } -extern void st_write_done (st_parameter_dt *); -export_proto(st_write_done); void -st_write_done (st_parameter_dt *dtp) +st_write_done_worker (st_parameter_dt *dtp) { finalize_transfer (dtp); @@ -4196,19 +4342,68 @@ void free_format_data (dtp->u.p.fmt); free_format (dtp); } + } +} + +extern void st_write_done (st_parameter_dt *); +export_proto(st_write_done); + +void +st_write_done (st_parameter_dt *dtp) +{ + if (dtp->u.p.current_unit) + { + if (dtp->u.p.current_unit->au) + { + if (dtp->common.flags & IOPARM_DT_HAS_ID) + *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, + AIO_WRITE_DONE); + else + { + enqueue_done (dtp->u.p.current_unit->au, AIO_WRITE_DONE); + /* An asynchronous unit without ASYNCHRONOUS="YES" - make this + synchronous by performing a wait operation. */ + if (!dtp->u.p.async) + async_wait (&dtp->common, dtp->u.p.current_unit->au); + } + } + else + st_write_done_worker (dtp); + unlock_unit (dtp->u.p.current_unit); } + library_end (); } +/* Wait operation. We need to keep around the do-nothing version + of st_wait for compatibility with previous versions, which had marked + the argument as unused (and thus liable to be removed). -/* F2003: This is a stub for the runtime portion of the WAIT statement. */ + TODO: remove at next bump in version number. */ + void st_wait (st_parameter_wait *wtp __attribute__((unused))) { + return; } +void +st_wait_async (st_parameter_wait *wtp) +{ + gfc_unit *u = find_unit (wtp->common.unit); + if (ASYNC_IO && u->au) + { + if (wtp->common.flags & IOPARM_WAIT_HAS_ID) + async_wait_id (&(wtp->common), u->au, *wtp->id); + else + async_wait (&(wtp->common), u->au); + } + unlock_unit (u); +} + + /* Receives the scalar information for namelist objects and stores it in a linked list of namelist_info types. */ Index: libgfortran/io/unit.c =================================================================== --- libgfortran/io/unit.c (revision 263244) +++ libgfortran/io/unit.c (working copy) @@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect #include "fbuf.h" #include "format.h" #include "unix.h" +#include "async.h" #include #include @@ -240,7 +241,7 @@ insert_unit (int n) #else __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock); #endif - __gthread_mutex_lock (&u->lock); + LOCK (&u->lock); u->priority = pseudo_random (); unit_root = insert (u, unit_root); return u; @@ -327,7 +328,9 @@ get_gfc_unit (int n, int do_create) gfc_unit *p; int c, created = 0; - __gthread_mutex_lock (&unit_lock); + NOTE ("Unit n=%d, do_create = %d", n, do_create); + LOCK (&unit_lock); + retry: for (c = 0; c < CACHE_SIZE; c++) if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n) @@ -366,7 +369,7 @@ retry: { /* Newly created units have their lock held already from insert_unit. Just unlock UNIT_LOCK and return. */ - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); return p; } @@ -374,10 +377,10 @@ found: if (p != NULL && (p->child_dtio == 0)) { /* Fast path. */ - if (! __gthread_mutex_trylock (&p->lock)) + if (! TRYLOCK (&p->lock)) { /* assert (p->closed == 0); */ - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); return p; } @@ -385,15 +388,15 @@ found: } - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); if (p != NULL && (p->child_dtio == 0)) { - __gthread_mutex_lock (&p->lock); + LOCK (&p->lock); if (p->closed) { - __gthread_mutex_lock (&unit_lock); - __gthread_mutex_unlock (&p->lock); + LOCK (&unit_lock); + UNLOCK (&p->lock); if (predec_waiting_locked (p) == 0) destroy_unit_mutex (p); goto retry; @@ -640,7 +643,7 @@ init_units (void) fbuf_init (u, 0); - __gthread_mutex_unlock (&u->lock); + UNLOCK (&u->lock); } if (options.stdout_unit >= 0) @@ -671,7 +674,7 @@ init_units (void) fbuf_init (u, 0); - __gthread_mutex_unlock (&u->lock); + UNLOCK (&u->lock); } if (options.stderr_unit >= 0) @@ -702,13 +705,13 @@ init_units (void) fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing any kind of exotic formatting to stderr. */ - __gthread_mutex_unlock (&u->lock); + UNLOCK (&u->lock); } /* The default internal units. */ u = insert_unit (GFC_INTERNAL_UNIT); - __gthread_mutex_unlock (&u->lock); + UNLOCK (&u->lock); u = insert_unit (GFC_INTERNAL_UNIT4); - __gthread_mutex_unlock (&u->lock); + UNLOCK (&u->lock); } @@ -717,6 +720,9 @@ close_unit_1 (gfc_unit *u, int locked) { int i, rc; + if (ASYNC_IO && u->au) + async_close (u->au); + /* If there are previously written bytes from a write with ADVANCE="no" Reposition the buffer before closing. */ if (u->previous_nonadvancing_write) @@ -726,7 +732,7 @@ close_unit_1 (gfc_unit *u, int locked) u->closed = 1; if (!locked) - __gthread_mutex_lock (&unit_lock); + LOCK (&unit_lock); for (i = 0; i < CACHE_SIZE; i++) if (unit_cache[i] == u) @@ -744,7 +750,7 @@ close_unit_1 (gfc_unit *u, int locked) newunit_free (u->unit_number); if (!locked) - __gthread_mutex_unlock (&u->lock); + UNLOCK (&u->lock); /* If there are any threads waiting in find_unit for this unit, avoid freeing the memory, the last such thread will free it @@ -753,7 +759,7 @@ close_unit_1 (gfc_unit *u, int locked) destroy_unit_mutex (u); if (!locked) - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); return rc; } @@ -761,7 +767,9 @@ close_unit_1 (gfc_unit *u, int locked) void unlock_unit (gfc_unit *u) { - __gthread_mutex_unlock (&u->lock); + NOTE ("unlock_unit = %d", u->unit_number); + UNLOCK (&u->lock); + NOTE ("unlock_unit done"); } /* close_unit()-- Close a unit. The stream is closed, and any memory @@ -785,10 +793,10 @@ close_unit (gfc_unit *u) void close_units (void) { - __gthread_mutex_lock (&unit_lock); + LOCK (&unit_lock); while (unit_root != NULL) close_unit_1 (unit_root, 1); - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); free (newunits); @@ -895,7 +903,7 @@ finish_last_advance_record (gfc_unit *u) int newunit_alloc (void) { - __gthread_mutex_lock (&unit_lock); + LOCK (&unit_lock); if (!newunits) { newunits = xcalloc (16, 1); @@ -909,7 +917,7 @@ newunit_alloc (void) { newunits[ii] = true; newunit_lwi = ii + 1; - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); return -ii + NEWUNIT_START; } } @@ -922,7 +930,7 @@ newunit_alloc (void) memset (newunits + old_size, 0, old_size); newunits[old_size] = true; newunit_lwi = old_size + 1; - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); return -old_size + NEWUNIT_START; } Index: libgfortran/io/unix.c =================================================================== --- libgfortran/io/unix.c (revision 263244) +++ libgfortran/io/unix.c (working copy) @@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect #include "io.h" #include "unix.h" +#include "async.h" #include #ifdef HAVE_UNISTD_H @@ -1742,7 +1743,7 @@ find_file (const char *file, gfc_charlen_type file id = id_from_path (path); #endif - __gthread_mutex_lock (&unit_lock); + LOCK (&unit_lock); retry: u = find_file0 (unit_root, FIND_FILE0_ARGS); if (u != NULL) @@ -1751,20 +1752,20 @@ retry: if (! __gthread_mutex_trylock (&u->lock)) { /* assert (u->closed == 0); */ - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); goto done; } inc_waiting_locked (u); } - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); if (u != NULL) { - __gthread_mutex_lock (&u->lock); + LOCK (&u->lock); if (u->closed) { - __gthread_mutex_lock (&unit_lock); - __gthread_mutex_unlock (&u->lock); + LOCK (&unit_lock); + UNLOCK (&u->lock); if (predec_waiting_locked (u) == 0) free (u); goto retry; @@ -1794,7 +1795,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit) return u; if (u->s) sflush (u->s); - __gthread_mutex_unlock (&u->lock); + UNLOCK (&u->lock); } u = u->right; } @@ -1807,17 +1808,17 @@ flush_all_units (void) gfc_unit *u; int min_unit = 0; - __gthread_mutex_lock (&unit_lock); + LOCK (&unit_lock); do { u = flush_all_units_1 (unit_root, min_unit); if (u != NULL) inc_waiting_locked (u); - __gthread_mutex_unlock (&unit_lock); + UNLOCK (&unit_lock); if (u == NULL) return; - __gthread_mutex_lock (&u->lock); + LOCK (&u->lock); min_unit = u->unit_number + 1; @@ -1824,14 +1825,14 @@ flush_all_units (void) if (u->closed == 0) { sflush (u->s); - __gthread_mutex_lock (&unit_lock); - __gthread_mutex_unlock (&u->lock); + LOCK (&unit_lock); + UNLOCK (&u->lock); (void) predec_waiting_locked (u); } else { - __gthread_mutex_lock (&unit_lock); - __gthread_mutex_unlock (&u->lock); + LOCK (&unit_lock); + UNLOCK (&u->lock); if (predec_waiting_locked (u) == 0) free (u); } Index: libgfortran/libgfortran.h =================================================================== --- libgfortran/libgfortran.h (revision 263244) +++ libgfortran/libgfortran.h (working copy) @@ -738,6 +738,9 @@ internal_proto(translate_error); extern void generate_error (st_parameter_common *, int, const char *); iexport_proto(generate_error); +extern bool generate_error_common (st_parameter_common *, int, const char *); +iexport_proto(generate_error_common); + extern void generate_warning (st_parameter_common *, const char *); internal_proto(generate_warning); @@ -1743,5 +1746,7 @@ void cshift1_16_c16 (gfc_array_c16 * const restric internal_proto(cshift1_16_c16); #endif +/* Define this if we support asynchronous I/O on this platform. This + currently requires weak symbols. */ #endif /* LIBGFOR_H */ Index: libgfortran/runtime/error.c =================================================================== --- libgfortran/runtime/error.c (revision 263244) +++ libgfortran/runtime/error.c (working copy) @@ -24,6 +24,9 @@ see the files COPYING3 and COPYING.RUNTIME respect #include "libgfortran.h" +#include "io.h" +#include "async.h" + #include #include #include @@ -526,24 +529,41 @@ translate_error (int code) } -/* generate_error()-- Come here when an error happens. This - * subroutine is called if it is possible to continue on after the error. - * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or - * ERR labels are present, we return, otherwise we terminate the program - * after printing a message. The error code is always required but the - * message parameter can be NULL, in which case a string describing - * the most recent operating system error is used. */ +/* Worker function for generate_error and generate_error_async. Return true + if a straight return is to be done, zero if the program should abort. */ -void -generate_error (st_parameter_common *cmp, int family, const char *message) +bool +generate_error_common (st_parameter_common *cmp, int family, const char *message) { char errmsg[STRERR_MAXSZ]; +#if ASYNC_IO + gfc_unit *u; + + NOTE ("Entering generate_error_common"); + + u = thread_unit; + if (u && u->au) + { + if (u->au->error.has_error) + return true; + + if (__gthread_equal (u->au->thread, __gthread_self ())) + { + u->au->error.has_error = 1; + u->au->error.cmp = cmp; + u->au->error.family = family; + u->au->error.message = message; + return true; + } + } +#endif + /* If there was a previous error, don't mask it with another error message, EOF or EOR condition. */ if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR) - return; + return true; /* Set the error status. */ if ((cmp->flags & IOPARM_HAS_IOSTAT)) @@ -562,29 +582,30 @@ translate_error (int code) switch (family) { case LIBERROR_EOR: - cmp->flags |= IOPARM_LIBRETURN_EOR; + cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR"); if ((cmp->flags & IOPARM_EOR)) - return; + return true; break; case LIBERROR_END: - cmp->flags |= IOPARM_LIBRETURN_END; + cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END"); if ((cmp->flags & IOPARM_END)) - return; + return true; break; default: - cmp->flags |= IOPARM_LIBRETURN_ERROR; + cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR"); if ((cmp->flags & IOPARM_ERR)) - return; + return true; break; } /* Return if the user supplied an iostat variable. */ if ((cmp->flags & IOPARM_HAS_IOSTAT)) - return; + return true; - /* Terminate the program */ + /* Return code, caller is responsible for terminating + the program if necessary. */ recursion_check (); show_locus (cmp); @@ -591,8 +612,27 @@ translate_error (int code) estr_write ("Fortran runtime error: "); estr_write (message); estr_write ("\n"); - exit_error (2); + return false; } + +/* generate_error()-- Come here when an error happens. This + * subroutine is called if it is possible to continue on after the error. + * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or + * ERR labels are present, we return, otherwise we terminate the program + * after printing a message. The error code is always required but the + * message parameter can be NULL, in which case a string describing + * the most recent operating system error is used. + * If the error is for an asynchronous unit and if the program is currently + * executing the asynchronous thread, just mark the error and return. */ + +void +generate_error (st_parameter_common *cmp, int family, const char *message) +{ + if (generate_error_common (cmp, family, message)) + return; + + exit_error(2); +} iexport(generate_error); --sdjvelw7zuufge36 Content-Type: text/plain; charset="us-ascii" Content-Disposition: attachment; filename="async_io_1.f90" Content-length: 1426 ! { dg-do run } !TODO: Move these testcases to gfortran testsuite ! once compilation with pthreads is supported there ! 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 (10, file='a.dat', asynchronous=yes) cc = (1.5, 0.5) inquire (10,asynchronous=inq) if (inq /= "YES") stop 1 write (10,*,asynchronous=yes) 4, 3 write (10,*,asynchronous=yes) 2, 1 write (10,*,asynchronous=yes) 1.0, 3.0 write (10,'(A)', asynchronous=yes) 'asdf' write (10,*, asynchronous=yes) cc close (10) open (20, file='a.dat', asynchronous=yes) read (20, *, asynchronous=yes) i, j read (20, *, asynchronous=yes) k, l read (20, *, asynchronous=yes) a, b read (20,'(A4)',asynchronous=yes) str read (20,*, asynchronous=yes) dd wait (20) if (i /= 4 .or. j /= 3) stop 2 if (k /= 2 .or. l /= 1) stop 3 if (a /= 1.0 .or. b /= 3.0) stop 4 if (str /= 'asdf') stop 5 if (cc /= dd) stop 6 close (20,status="delete") open(10, file='c.dat', asynchronous=yes) write(10, *, asynchronous=yes) is close(10) open(20, file='c.dat', asynchronous=yes) read(20, *, asynchronous=yes) res wait (20) if (any(res /= is)) stop 7 close (20,status="delete") end program --sdjvelw7zuufge36 Content-Type: text/plain; charset="us-ascii" Content-Disposition: attachment; filename="async_io_2.f90" Content-length: 473 ! { dg-do run } !TODO: Move these testcases to gfortran testsuite ! once compilation with pthreads is supported there program main implicit none integer :: i, ios character(len=100) :: iom open (10,file="tst.dat") write (10,'(A4)') 'asdf' close(10) i = 234 open(10,file="tst.dat", asynchronous="yes") read (10,'(I4)',asynchronous="yes") i iom = ' ' wait (10,iostat=ios,iomsg=iom) if (iom == ' ') stop 1 close(10,status="delete") end program main --sdjvelw7zuufge36 Content-Type: text/plain; charset="us-ascii" Content-Disposition: attachment; filename="async_io_3.f90" Content-length: 462 !TODO: Move these testcases to gfortran testsuite ! once compilation with pthreads is supported there ! { dg-do run } program main integer :: i open (10,file="tst.dat") write (10,'(A4)') 'asdf' close(10) i = 234 open(10,file="tst.dat", asynchronous="yes") read (10,'(I4)',asynchronous="yes") i wait(10) end program main ! { dg-output "Fortran runtime error: Bad value during integer read" } ! { dg-final { remote_file build delete "tst.dat" } } --sdjvelw7zuufge36 Content-Type: text/plain; charset="us-ascii" Content-Disposition: attachment; filename="async_io_4.f90" Content-length: 1788 ! { dg-do run { target fd_truncate } } !TODO: Move these testcases to gfortran testsuite ! once compilation with pthreads is supported there ! Test BACKSPACE for synchronous and asynchronous I/O program main integer i, n, nr real x(10), y(10) ! PR libfortran/20068 open (20, status='scratch', asynchronous="yes") write (20,*, asynchronous="yes" ) 1 write (20,*, asynchronous="yes") 2 write (20,*, asynchronous="yes") 3 rewind (20) i = 41 read (20,*, asynchronous="yes") i wait (20) if (i .ne. 1) STOP 1 write (*,*) ' ' backspace (20) i = 42 read (20,*, asynchronous="yes") i close (20) if (i .ne. 1) STOP 2 ! PR libfortran/20125 open (20, status='scratch', asynchronous="yes") write (20,*, asynchronous="yes") 7 backspace (20) read (20,*, asynchronous="yes") i wait (20) if (i .ne. 7) STOP 3 close (20) open (20, status='scratch', form='unformatted') write (20) 8 backspace (20) read (20) i if (i .ne. 8) STOP 4 close (20) ! PR libfortran/20471 do n = 1, 10 x(n) = sqrt(real(n)) end do open (3, form='unformatted', status='scratch') write (3) (x(n),n=1,10) backspace (3) rewind (3) read (3) (y(n),n=1,10) do n = 1, 10 if (abs(x(n)-y(n)) > 0.00001) STOP 5 end do close (3) ! PR libfortran/20156 open (3, form='unformatted', status='scratch') do i = 1, 5 x(1) = i write (3) n, (x(n),n=1,10) end do nr = 0 rewind (3) 20 continue read (3,end=30,err=90) n, (x(n),n=1,10) nr = nr + 1 goto 20 30 continue if (nr .ne. 5) STOP 6 do i = 1, nr+1 backspace (3) end do do i = 1, nr read(3,end=70,err=90) n, (x(n),n=1,10) if (abs(x(1) - i) .gt. 0.001) STOP 7 end do close (3) stop 70 continue STOP 8 90 continue STOP 9 end program --sdjvelw7zuufge36 Content-Type: text/plain; charset="us-ascii" Content-Disposition: attachment; filename="async_io_5.f90" Content-length: 3788 ! { dg-do run } !TODO: Move these testcases to gfortran testsuite ! once compilation with pthreads is supported there ! PR55818 Reading a REAL from a file which doesn't end in a new line fails ! Test case from PR reporter. implicit none integer :: stat !integer :: var ! << works real :: var ! << fails character(len=10) :: cvar ! << fails complex :: cval logical :: lvar open(99, file="test.dat", access="stream", form="unformatted", status="new") write(99) "1", new_line("") write(99) "2", new_line("") write(99) "3" close(99) ! Test character kind open(99, file="test.dat") read (99,*, iostat=stat) cvar if (stat /= 0 .or. cvar /= "1") STOP 1 read (99,*, iostat=stat) cvar if (stat /= 0 .or. cvar /= "2") STOP 2 read (99,*, iostat=stat) cvar ! << FAILS: stat /= 0 if (stat /= 0 .or. cvar /= "3") STOP 3 ! << aborts here ! Test real kind rewind(99) read (99,*, iostat=stat) var if (stat /= 0 .or. var /= 1.0) STOP 4 read (99,*, iostat=stat) var if (stat /= 0 .or. var /= 2.0) STOP 5 read (99,*, iostat=stat) var ! << FAILS: stat /= 0 if (stat /= 0 .or. var /= 3.0) STOP 6 close(99, status="delete") ! Test real kind with exponents open(99, file="test.dat", access="stream", form="unformatted", status="new") write(99) "1.0e3", new_line("") write(99) "2.0e-03", new_line("") write(99) "3.0e2" close(99) open(99, file="test.dat") read (99,*, iostat=stat) var if (stat /= 0) STOP 7 read (99,*, iostat=stat) var if (stat /= 0) STOP 8 read (99,*) var ! << FAILS: stat /= 0 if (stat /= 0) STOP 9 close(99, status="delete") ! Test logical kind open(99, file="test.dat", access="stream", form="unformatted", status="new") write(99) "Tru", new_line("") write(99) "fal", new_line("") write(99) "t" close(99) open(99, file="test.dat") read (99,*, iostat=stat) lvar if (stat /= 0 .or. (.not.lvar)) STOP 10 read (99,*, iostat=stat) lvar if (stat /= 0 .or. lvar) STOP 11 read (99,*) lvar ! << FAILS: stat /= 0 if (stat /= 0 .or. (.not.lvar)) STOP 12 close(99, status="delete") ! Test combinations of Inf and Nan open(99, file="test.dat", access="stream", form="unformatted", status="new") write(99) "infinity", new_line("") write(99) "nan", new_line("") write(99) "infinity" close(99) open(99, file="test.dat") read (99,*, iostat=stat) var if (stat /= 0) STOP 13 read (99,*, iostat=stat) var if (stat /= 0) STOP 14 read (99,*) var ! << FAILS: stat /= 0 if (stat /= 0) STOP 1! << aborts here close(99, status="delete") open(99, file="test.dat", access="stream", form="unformatted", status="new") write(99) "infinity", new_line("") write(99) "inf", new_line("") write(99) "nan" close(99) open(99, file="test.dat") read (99,*, iostat=stat) var if (stat /= 0) STOP 15 read (99,*, iostat=stat) var if (stat /= 0) STOP 16 read (99,*) var ! << FAILS: stat /= 0 if (stat /= 0) STOP 2! << aborts here close(99, status="delete") open(99, file="test.dat", access="stream", form="unformatted", status="new") write(99) "infinity", new_line("") write(99) "nan", new_line("") write(99) "inf" close(99) open(99, file="test.dat") read (99,*, iostat=stat) var if (stat /= 0) STOP 17 read (99,*, iostat=stat) var if (stat /= 0) STOP 18 read (99,*) var ! << FAILS: stat /= 0 if (stat /= 0) STOP 3! << aborts here close(99, status="delete") ! Test complex kind open(99, file="test.dat", access="stream", form="unformatted", status="new") write(99) "(1,2)", new_line("") write(99) "(2,3)", new_line("") write(99) "(4,5)" close(99) open(99, file="test.dat") read (99,*, iostat=stat) cval if (stat /= 0 .or. cval /= cmplx(1,2)) STOP 19 read (99,*, iostat=stat) cval if (stat /= 0 .or. cval /= cmplx(2,3)) STOP 20 read (99,*, iostat=stat) cval ! << FAILS: stat /= 0, value is okay if (stat /= 0 .or. cval /= cmplx(4,5)) STOP 21 close(99, status="delete") end --sdjvelw7zuufge36 Content-Type: text/plain; charset="us-ascii" Content-Disposition: attachment; filename="async_io_6.f90" Content-length: 534 ! { dg-do run } !TODO: Move these testcases to gfortran testsuite ! once compilation with pthreads is supported there ! PR 22390 Implement flush statement program flush_1 character(len=256) msg integer ios open (unit=10, access='SEQUENTIAL', status='SCRATCH') write (10, *) 42 flush 10 write (10, *) 42 flush(10) write (10, *) 42 flush(unit=10, iostat=ios) if (ios /= 0) STOP 1 write (10, *) 42 flush (unit=10, err=20) goto 30 20 STOP 2 30 continue call flush(10) end program flush_1 --sdjvelw7zuufge36 Content-Type: text/plain; charset="us-ascii" Content-Disposition: attachment; filename="async_io_7.f90" Content-length: 680 ! { dg-do run } !TODO: Move these testcases to gfortran testsuite ! once compilation with pthreads is supported there ! PR40008 F2008: Add NEWUNIT= for OPEN statement ! Contributed by Jerry DeLisle program newunit_1 character(len=25) :: str integer(1) :: myunit, myunit2 myunit = 25 str = "bad" open(newunit=myunit, status="scratch") open(newunit = myunit2, file="newunit_1file") write(myunit,'(e24.15e2)') 1.0d0 write(myunit2,*) "abcdefghijklmnop" flush(myunit) rewind(myunit) rewind(myunit2) read(myunit2,'(a)') str if (str.ne." abcdefghijklmnop") STOP 1 close(myunit) close(myunit2, status="delete") end program newunit_1 --sdjvelw7zuufge36--