[Bug libfortran/78549] [8 Regression] Very slow formatted internal file output

[tkoenig at gcc dot gnu.org]

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=78549

--- Comment #16 from Thomas Koenig <tkoenig at gcc dot gnu.org> ---
Jerry,

what do you think of this approach? This creates a local copy
of the gfc_unit, without putting it into the tree.

Index: transfer.c
===================================================================
--- transfer.c  (Revision 253377)
+++ transfer.c  (Arbeitskopie)
@@ -4170,6 +4170,9 @@ st_write_done (st_parameter_dt *dtp)
        }
       unlock_unit (dtp->u.p.current_unit);
     }
+  if (is_internal_unit (dtp))
+    free (dtp->u.p.current_unit);
+
   library_end ();
 }

Index: unit.c
===================================================================
--- unit.c      (Revision 253377)
+++ unit.c      (Arbeitskopie)
@@ -225,7 +225,7 @@ insert (gfc_unit *new, gfc_unit *t)
 /* insert_unit()-- Create a new node, insert it into the treap.  */

 static gfc_unit *
-insert_unit (int n)
+insert_unit (int n, int internal)
 {
   gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
   u->unit_number = n;
@@ -238,8 +238,11 @@ static gfc_unit *
   __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
 #endif
   __gthread_mutex_lock (&u->lock);
-  u->priority = pseudo_random ();
-  unit_root = insert (u, unit_root);
+  if (!internal)
+    {
+      u->priority = pseudo_random ();
+      unit_root = insert (u, unit_root);
+    }
   return u;
 }

@@ -316,14 +319,21 @@ delete_unit (gfc_unit *old)

 /* get_gfc_unit()-- Given an integer, return a pointer to the unit
    structure.  Returns NULL if the unit does not exist,
-   otherwise returns a locked unit. */
+   otherwise returns a locked unit.  If internal, do not put it
+   in the unit cache.  */

 static gfc_unit *
-get_gfc_unit (int n, int do_create)
+get_gfc_unit (int n, int do_create, int internal)
 {
   gfc_unit *p;
   int c, created = 0;

+  if (internal)
+    {
+      p = insert_unit (n, 1);
+      return p;
+    }
+  
   __gthread_mutex_lock (&unit_lock);
 retry:
   for (c = 0; c < CACHE_SIZE; c++)
@@ -347,7 +357,7 @@ retry:

   if (p == NULL && do_create)
     {
-      p = insert_unit (n);
+      p = insert_unit (n, 0);
       created = 1;
     }

@@ -405,7 +415,7 @@ found:
 gfc_unit *
 find_unit (int n)
 {
-  return get_gfc_unit (n, 0);
+  return get_gfc_unit (n, 0, 0);
 }


@@ -412,7 +422,7 @@ find_unit (int n)
 gfc_unit *
 find_or_create_unit (int n)
 {
-  return get_gfc_unit (n, 1);
+  return get_gfc_unit (n, 1, 0);
 }


@@ -548,7 +558,7 @@ get_unit (st_parameter_dt *dtp, int do_create)

       dtp->u.p.unit_is_internal = 1;
       dtp->common.unit = newunit_alloc ();
-      unit = get_gfc_unit (dtp->common.unit, do_create);
+      unit = get_gfc_unit (dtp->common.unit, do_create, 1);
       set_internal_unit (dtp, unit, kind);
       fbuf_init (unit, 128);
       return unit;
@@ -563,9 +573,9 @@ 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);
+    return get_gfc_unit (dtp->common.unit, 0, 0);

-  return get_gfc_unit (dtp->common.unit, do_create);
+  return get_gfc_unit (dtp->common.unit, do_create, 0);
 }


@@ -592,7 +602,7 @@ init_units (void)

   if (options.stdin_unit >= 0)
     {                          /* STDIN */
-      u = insert_unit (options.stdin_unit);
+      u = insert_unit (options.stdin_unit, 0);
       u->s = input_stream ();

       u->flags.action = ACTION_READ;
@@ -624,7 +634,7 @@ init_units (void)

   if (options.stdout_unit >= 0)
     {                          /* STDOUT */
-      u = insert_unit (options.stdout_unit);
+      u = insert_unit (options.stdout_unit, 0);
       u->s = output_stream ();

       u->flags.action = ACTION_WRITE;
@@ -655,7 +665,7 @@ init_units (void)

   if (options.stderr_unit >= 0)
     {                          /* STDERR */
-      u = insert_unit (options.stderr_unit);
+      u = insert_unit (options.stderr_unit, 0);
       u->s = error_stream ();

       u->flags.action = ACTION_WRITE;