re PR libfortran/78549 (Very slow formatted internal file output)

2017-12-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

        PR libgfortran/78549
        * io/inquire.c (inquire_via_unit): Adjust test for existence for
        pre-connected internal units.
        * io/transfer.c (finalize_transfer): When done with a transfer
        to internal units, free the format buffer and close the stream.
        (st_read_done): Delete freeing the stream, now handled using
        sclose in finalize_transfer. (st_write_done): Likewise.
        * io/unit.c (get_unit): Return NULL for special reserved unit
        numbers, signifying not accessible to the user.
        (init_units): Insert the two special internal units into the
        unit treap. This makes these unit structures available without
        further allocations for later use by internal unit I/O. These
        units are automatically deleted by normal program termination.
        * io/unix.c (mem_close): Add a guard check to protect from double free.

From-SVN: r255621

libgfortran/ChangeLog

+2017-12-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libgfortran/78549
+	* io/inquire.c (inquire_via_unit): Adjust test for existence for
+	pre-connected internal units.
+	* io/transfer.c (finalize_transfer): When done with a transfer
+	to internal units, free the format buffer and close the stream.
+	(st_read_done): Delete freeing the stream, now handled using
+	sclose in finalize_transfer. (st_write_done): Likewise.
+	* io/unit.c (get_unit): Return NULL for special reserved unit
+	numbers, signifying not accessible to the user.
+	(init_units): Insert the two special internal units into the
+	unit treap. This makes these unit structures available without
+	further allocations for later use by internal unit I/O. These
+	units are automatically deleted by normal program termination.
+	* io/unix.c (mem_close): Add a guard check to protect from double free.
+
 2017-12-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/36313

libgfortran/io/inquire.c

@@ -47,7 +47,10 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit *u)
     generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL);
 
   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
-    *iqp->exist = (u != NULL) || (iqp->common.unit >= 0);
+    *iqp->exist = (u != NULL &&
+		   iqp->common.unit != GFC_INTERNAL_UNIT &&
+		   iqp->common.unit != GFC_INTERNAL_UNIT4)
+		|| (iqp->common.unit >= 0);
 
   if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
     *iqp->opened = (u != NULL);

libgfortran/io/transfer.c

@@ -3985,6 +3985,19 @@ finalize_transfer (st_parameter_dt *dtp)
   next_record (dtp, 1);
 
  done:
+
+  if (dtp->u.p.unit_is_internal)
+    {
+      fbuf_destroy (dtp->u.p.current_unit);
+      if (dtp->u.p.current_unit
+	  && (dtp->u.p.current_unit->child_dtio  == 0)
+	  && dtp->u.p.current_unit->s)
+	{
+	  sclose (dtp->u.p.current_unit->s);
+	  dtp->u.p.current_unit->s = NULL;
+	}
+    }
+
 #ifdef HAVE_USELOCALE
   if (dtp->u.p.old_locale != (locale_t) 0)
     {
@@ -4094,8 +4107,6 @@ st_read_done (st_parameter_dt *dtp)
 	    {
 	      free (dtp->u.p.current_unit->filename);
 	      dtp->u.p.current_unit->filename = NULL;
-	      free (dtp->u.p.current_unit->s);
-	      dtp->u.p.current_unit->s = NULL;
 	      if (dtp->u.p.current_unit->ls)
 		free (dtp->u.p.current_unit->ls);
 	      dtp->u.p.current_unit->ls = NULL;
@@ -4165,8 +4176,6 @@ st_write_done (st_parameter_dt *dtp)
 	    {
 	      free (dtp->u.p.current_unit->filename);
 	      dtp->u.p.current_unit->filename = NULL;
-	      free (dtp->u.p.current_unit->s);
-	      dtp->u.p.current_unit->s = NULL;
 	      if (dtp->u.p.current_unit->ls)
 		free (dtp->u.p.current_unit->ls);
 	      dtp->u.p.current_unit->ls = NULL;

libgfortran/io/unit.c

@@ -566,7 +566,11 @@ get_unit (st_parameter_dt *dtp, int do_create)
      is not allowed, such units must be created with
      OPEN(NEWUNIT=...).  */
   if (dtp->common.unit < 0)
-    return get_gfc_unit (dtp->common.unit, 0);
+    {
+      if (dtp->common.unit > NEWUNIT_START) /* Reserved units.  */
+	return NULL;
+      return get_gfc_unit (dtp->common.unit, 0);
+    }
 
   return get_gfc_unit (dtp->common.unit, do_create);
 }
@@ -701,6 +705,9 @@ init_units (void)
 
       __gthread_mutex_unlock (&u->lock);
     }
+  /* The default internal units.  */
+  u = insert_unit (GFC_INTERNAL_UNIT);
+  u = insert_unit (GFC_INTERNAL_UNIT4);
 }
 
 

libgfortran/io/unix.c

@@ -962,8 +962,8 @@ mem_flush (unix_stream *s __attribute__ ((unused)))
 static int
 mem_close (unix_stream *s)
 {
-  free (s);
-
+  if (s)
+    free (s);
   return 0;
 }