[fortran,patch] Don't write common more than once in a module file (PR 30285)

[fortran,patch] Don't write common more than once in a module file (PR 30285)

[FX Coudert]

[-- Attachment #1: Type: text/plain, Size: 1176 bytes --]

PR 30285 is about deeply nested module files containing commons,  
which take a huge amount of memory when they're read back (and loads  
of disk space, but that's not so much of a problem). This commonly  
happens with MPICH and openmpi, and leads some people to run out of  
memory when compiling mpi-enabled programs.

The problem is that we write each common name more than once (a  
number of times that grows exponentially with the nesting). I tried  
to change the way we load modules, to avoid creating these duplicate  
symbols, but the diagnostics code for commons with binding labels  
requires this creation of multiple symbols, so I went for something  
that is a bit of a hack: we get rid of duplicate common names  
(specificaly: duplicate pairs of name and binding label) when writing  
the module files, by creating a list of them as we go through and  
checking them against that list.

I agree it's not a perfect solution, but I couldn't make it work in  
any other way (see the PR for a tentative patch), and I think it's  
worth committing now, as it's a serious problem for our users.  
Regtested on x86_64-linux, OK to commit?

FX



:ADDPATCH fortran:

[-- Attachment #2: pr30285.ChangeLog --]
[-- Type: application/octet-stream, Size: 226 bytes --]

2007-11-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

	PR fortran/30285
	* module.c (struct written_common, write_common0): New structure
	and function.
	(write_common): Avoid to write the same common more than once.


[-- Attachment #3: pr30285.diff --]
[-- Type: application/octet-stream, Size: 2387 bytes --]

Index: module.c
===================================================================
--- module.c	(revision 129869)
+++ module.c	(working copy)
@@ -3767,30 +3767,50 @@ gfc_check_access (gfc_access specific_ac
 }
 
 
-/* Write a common block to the module.  */
+struct written_common
+{
+  const char *name, *label;
+  struct written_common *next;
+};
+
+static struct written_common *written_common;
+
+/* Write a common block to the module -- recursive helper function.  */
 
 static void
-write_common (gfc_symtree *st)
+write_common_0 (gfc_symtree *st)
 {
   gfc_common_head *p;
   const char * name;
   int flags;
   const char *label;
+  struct written_common *w;
 	      
   if (st == NULL)
     return;
 
-  write_common (st->left);
-  write_common (st->right);
-
-  mio_lparen ();
+  write_common_0 (st->left);
+  write_common_0 (st->right);
 
   /* Write the unmangled name.  */
   name = st->n.common->name;
+  p = st->n.common;
+
+  /* We will write out the binding label, or the name if no label given.  */
+  if (p->is_bind_c)
+    label = p->binding_label;
+  else
+    label = p->name;
+
+  /* Check if we've already output this common.  */
+  for (w = written_common; w; w = w->next)
+    if (strcmp (w->name, name) == 0 && strcmp (w->label, label) == 0)
+      return;
+
+  mio_lparen ();
 
   mio_pool_string (&name);
 
-  p = st->n.common;
   mio_symbol_ref (&p->head);
   flags = p->saved ? 1 : 0;
   if (p->threadprivate) flags |= 2;
@@ -3799,19 +3819,34 @@ write_common (gfc_symtree *st)
   /* Write out whether the common block is bind(c) or not.  */
   mio_integer (&(p->is_bind_c));
 
-  /* Write out the binding label, or the com name if no label given.  */
-  if (p->is_bind_c)
-    {
-      label = p->binding_label;
-      mio_pool_string (&label);
-    }
-  else
+  mio_pool_string (&label);
+  mio_rparen ();
+
+  /* Record that we have written this common.  */
+  w = gfc_getmem (sizeof (struct written_common));
+  w->next = written_common;
+  written_common = w;
+  w->name = p->name;
+  w->label = label;
+}
+
+
+/* Set up */
+static void
+write_common (gfc_symtree *st)
+{
+  struct written_common *w, *w2;
+
+  written_common = NULL;
+  write_common_0 (st);
+
+  w = written_common;
+  while (w)
     {
-      label = p->name;
-      mio_pool_string (&label);
+      w2 = w->next;
+      gfc_free (w);
+      w = w2;
     }
-
-  mio_rparen ();
 }
 
 

Re: [fortran,patch] Don't write common more than once in a module file (PR 30285)

[Tobias Schlüter]

FX Coudert wrote:
> @@ -3767,30 +3767,50 @@ gfc_check_access (gfc_access specific_ac
>  }
>  
>  
> -/* Write a common block to the module.  */
> +struct written_common
> +{
> +  const char *name, *label;
> +  struct written_common *next;
> +};
> +
> +static struct written_common *written_common;

Please call the variable written_commons, otherwise the name 
written_common is overloaded with different meanings.

> +  /* Check if we've already output this common.  */
> +  for (w = written_common; w; w = w->next)
> +    if (strcmp (w->name, name) == 0 && strcmp (w->label, label) == 0)
> +      return;

This is quadratic in the numbers of commons in a module.  Please make 
written_common a balanced tree (such as our BBT_HEADER & associates, 
this would leave us with O(N log(N)) complexity) or a hashtable (leaving 
us with O(N) or something like that).  A non-algorithmic speedup would 
be comparing the pointers directly, since as they are allocated strings 
they're guaranteed to be different strings if they point to different 
locations.

Other than that, this looks ok.

Thanks,
- Tobi

Re: [fortran,patch] Don't write common more than once in a module file (PR 30285)

[FX Coudert]

> Please call the variable written_commons, otherwise the name  
> written_common is overloaded with different meanings.

OK.

>> +  /* Check if we've already output this common.  */
>> +  for (w = written_common; w; w = w->next)
>> +    if (strcmp (w->name, name) == 0 && strcmp (w->label, label)  
>> == 0)
>> +      return;
>
> This is quadratic in the numbers of commons in a module.  Please  
> make written_common a balanced tree (such as our BBT_HEADER &  
> associates, this would leave us with O(N log(N)) complexity) or a  
> hashtable (leaving us with O(N) or something like that).

Hum... Don't hurt me, I'm a mere chemist! :)

I'll look into it, and post an updated patch. Until then, though:

> A non-algorithmic speedup would be comparing the pointers directly,  
> since as they are allocated strings they're guaranteed to be  
> different strings if they point to different locations.

Hum, they're static buffers actually, so I don't think I can do that,  
unfortunately :(

typedef struct gfc_common_head
{
   locus where;
   char use_assoc, saved, threadprivate;
   char name[GFC_MAX_SYMBOL_LEN + 1];
   struct gfc_symbol *head;
   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
   int is_bind_c;
}
gfc_common_head;


Thanks,
FX

Re: [fortran,patch] Don't write common more than once in a module file (PR 30285)

[FX Coudert]

[-- Attachment #1: Type: text/plain, Size: 496 bytes --]

>> This is quadratic in the numbers of commons in a module.  Please  
>> make written_common a balanced tree (such as our BBT_HEADER &  
>> associates, this would leave us with O(N log(N)) complexity) or a  
>> hashtable (leaving us with O(N) or something like that).
>

Here's the updated patch, using a balanced tree. A careful review is  
welcome, as it's the first time I deal with these bbt features.

Boostrapped and finishing regtesting on x86_64-linux. OK to commit if  
it passes?

FX



[-- Attachment #2: pr30285_2.diff --]
[-- Type: application/octet-stream, Size: 3043 bytes --]

Index: module.c
===================================================================
--- module.c	(revision 130234)
+++ module.c	(working copy)
@@ -3767,30 +3767,82 @@ gfc_check_access (gfc_access specific_ac
 }
 
 
-/* Write a common block to the module.  */
+struct written_common
+{
+  BBT_HEADER(written_common);
+  const char *name, *label;
+};
+
+static int
+compare_written_commons (void *a1, void *b1)
+{
+  const char *aname = ((struct written_common *) a1)->name;
+  const char *alabel = ((struct written_common *) a1)->label;
+  const char *bname = ((struct written_common *) b1)->name;
+  const char *blabel = ((struct written_common *) b1)->label;
+  int c;
+
+  return ((c = strcmp (aname, bname)) != 0 ? c : strcmp (alabel, blabel));
+}
 
 static void
-write_common (gfc_symtree *st)
+free_written_common (struct written_common *w)
+{
+  if (!w)
+    return;
+
+  if (w->left)
+    free_written_common (w->left);
+  if (w->right)
+    free_written_common (w->right);
+
+  gfc_free (w);
+}
+
+static struct written_common *written_commons = NULL;
+
+/* Write a common block to the module -- recursive helper function.  */
+
+static void
+write_common_0 (gfc_symtree *st)
 {
   gfc_common_head *p;
   const char * name;
-  int flags;
+  int flags, c, i;
   const char *label;
+  struct written_common *w;
 	      
   if (st == NULL)
     return;
 
-  write_common (st->left);
-  write_common (st->right);
-
-  mio_lparen ();
+  write_common_0 (st->left);
+  write_common_0 (st->right);
 
   /* Write the unmangled name.  */
   name = st->n.common->name;
+  p = st->n.common;
+
+  /* We will write out the binding label, or the name if no label given.  */
+  if (p->is_bind_c)
+    label = p->binding_label;
+  else
+    label = p->name;
+
+  /* Check if we've already output this common.  */
+  w = written_commons;
+  while (w)
+    {
+      c = ((i = strcmp (name, w->name)) != 0 ? i : strcmp (label, w->label));
+      if (c == 0)
+	return;
+
+      w = (c < 0) ? w->left : w->right;
+    }
+
+  mio_lparen ();
 
   mio_pool_string (&name);
 
-  p = st->n.common;
   mio_symbol_ref (&p->head);
   flags = p->saved ? 1 : 0;
   if (p->threadprivate) flags |= 2;
@@ -3799,19 +3851,25 @@ write_common (gfc_symtree *st)
   /* Write out whether the common block is bind(c) or not.  */
   mio_integer (&(p->is_bind_c));
 
-  /* Write out the binding label, or the com name if no label given.  */
-  if (p->is_bind_c)
-    {
-      label = p->binding_label;
-      mio_pool_string (&label);
-    }
-  else
-    {
-      label = p->name;
-      mio_pool_string (&label);
-    }
-
+  mio_pool_string (&label);
   mio_rparen ();
+
+  /* Record that we have written this common.  */
+  w = gfc_getmem (sizeof (struct written_common));
+  w->name = p->name;
+  w->label = label;
+  gfc_insert_bbt (&written_commons, w, compare_written_commons);
+}
+
+
+/* Set up */
+static void
+write_common (gfc_symtree *st)
+{
+  written_commons = NULL;
+  write_common_0 (st);
+  free_written_common (written_commons);
+  written_commons = NULL;
 }
 
 

Re: [fortran,patch] Don't write common more than once in a module file (PR 30285)

[Tobias Schlüter]

FX Coudert wrote:
> Hum, they're static buffers actually, so I don't think I can do that, 
> unfortunately :(
> 
> typedef struct gfc_common_head
> {
>   locus where;
>   char use_assoc, saved, threadprivate;
>   char name[GFC_MAX_SYMBOL_LEN + 1];
>   struct gfc_symbol *head;
>   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
>   int is_bind_c;
> }
> gfc_common_head;

Whoops, that's an error then.  But I don't think it's worth fixing at 
this point.

> +static int
> +compare_written_commons (void *a1, void *b1)
> +{
> +  const char *aname = ((struct written_common *) a1)->name;
> +  const char *alabel = ((struct written_common *) a1)->label;
> +  const char *bname = ((struct written_common *) b1)->name;
> +  const char *blabel = ((struct written_common *) b1)->label;
> +  int c;
> +
> +  return ((c = strcmp (aname, bname)) != 0 ? c : strcmp (alabel, blabel));
> +}

That's smart :-)  I just pasted it to write that it's wrong but then I 
figured it out :-)  It would be simpler if you moved the first strcmp 
two lines up.

The updated patch looks ok.

Thanks,
- Tobi

Re: [fortran,patch] Don't write common more than once in a module file (PR 30285)

[Tobias Schlüter]

Tobias Schlüter wrote:
> The updated patch looks ok.

Sorry, that I didn't think of this earlier.  If you haven't committed 
the patch yet, and since you're touching it, can you please change the 
code to traverse the common tree in left-to-right order in order to 
prevent spurious differences between module files?  Note that there's an 
early return in write_common0, so you have to be a bit careful.

Thanks,
- Tobi

Re: [fortran,patch] Don't write common more than once in a module file (PR 30285)

[FX Coudert]

[-- Attachment #1: Type: text/plain, Size: 495 bytes --]

> Sorry, that I didn't think of this earlier.  If you haven't  
> committed the patch yet, and since you're touching it, can you  
> please change the code to traverse the common tree in left-to-right  
> order in order to prevent spurious differences between module  
> files?  Note that there's an early return in write_common0, so you  
> have to be a bit careful.

Here's what I've committed (using your recent change to write_symbol0  
as a model for tree traversing) as rev. 130257.

FX



[-- Attachment #2: pr30285_3.diff --]
[-- Type: application/octet-stream, Size: 4317 bytes --]

Index: module.c
===================================================================
--- module.c	(revision 130234)
+++ module.c	(working copy)
@@ -3767,51 +3767,119 @@ gfc_check_access (gfc_access specific_ac
 }
 
 
-/* Write a common block to the module.  */
+/* A structure to remember which commons we've already written.  */
+
+struct written_common
+{
+  BBT_HEADER(written_common);
+  const char *name, *label;
+};
+
+static struct written_common *written_commons = NULL;
+
+/* Comparison function used for balancing the binary tree.  */
+
+static int
+compare_written_commons (void *a1, void *b1)
+{
+  const char *aname = ((struct written_common *) a1)->name;
+  const char *alabel = ((struct written_common *) a1)->label;
+  const char *bname = ((struct written_common *) b1)->name;
+  const char *blabel = ((struct written_common *) b1)->label;
+  int c = strcmp (aname, bname);
+
+  return (c != 0 ? c : strcmp (alabel, blabel));
+}
+
+/* Free a list of written commons.  */
 
 static void
-write_common (gfc_symtree *st)
+free_written_common (struct written_common *w)
+{
+  if (!w)
+    return;
+
+  if (w->left)
+    free_written_common (w->left);
+  if (w->right)
+    free_written_common (w->right);
+
+  gfc_free (w);
+}
+
+/* Write a common block to the module -- recursive helper function.  */
+
+static void
+write_common_0 (gfc_symtree *st)
 {
   gfc_common_head *p;
   const char * name;
   int flags;
   const char *label;
+  struct written_common *w;
+  bool write_me = true;
 	      
   if (st == NULL)
     return;
 
-  write_common (st->left);
-  write_common (st->right);
+  write_common_0 (st->left);
 
-  mio_lparen ();
-
-  /* Write the unmangled name.  */
+  /* We will write out the binding label, or the name if no label given.  */
   name = st->n.common->name;
-
-  mio_pool_string (&name);
-
   p = st->n.common;
-  mio_symbol_ref (&p->head);
-  flags = p->saved ? 1 : 0;
-  if (p->threadprivate) flags |= 2;
-  mio_integer (&flags);
-
-  /* Write out whether the common block is bind(c) or not.  */
-  mio_integer (&(p->is_bind_c));
+  label = p->is_bind_c ? p->binding_label : p->name;
 
-  /* Write out the binding label, or the com name if no label given.  */
-  if (p->is_bind_c)
+  /* Check if we've already output this common.  */
+  w = written_commons;
+  while (w)
     {
-      label = p->binding_label;
-      mio_pool_string (&label);
+      int c = strcmp (name, w->name);
+      c = (c != 0 ? c : strcmp (label, w->label));
+      if (c == 0)
+	write_me = false;
+
+      w = (c < 0) ? w->left : w->right;
     }
-  else
+
+  if (write_me)
     {
-      label = p->name;
+      /* Write the common to the module.  */
+      mio_lparen ();
+      mio_pool_string (&name);
+
+      mio_symbol_ref (&p->head);
+      flags = p->saved ? 1 : 0;
+      if (p->threadprivate)
+	flags |= 2;
+      mio_integer (&flags);
+
+      /* Write out whether the common block is bind(c) or not.  */
+      mio_integer (&(p->is_bind_c));
+
       mio_pool_string (&label);
+      mio_rparen ();
+
+      /* Record that we have written this common.  */
+      w = gfc_getmem (sizeof (struct written_common));
+      w->name = p->name;
+      w->label = label;
+      gfc_insert_bbt (&written_commons, w, compare_written_commons);
     }
 
-  mio_rparen ();
+  write_common_0 (st->right);
+}
+
+
+/* Write a common, by initializing the list of written commons, calling
+   the recursive function write_common_0() and cleaning up afterwards.  */
+
+static void
+write_common (gfc_symtree *st)
+{
+  written_commons = NULL;
+  write_common_0 (st);
+  free_written_common (written_commons);
+  written_commons = NULL;
 }
 
 
Index: ChangeLog
===================================================================
--- ChangeLog	(revision 130256)
+++ ChangeLog	(working copy)
@@ -1,5 +1,13 @@
 2007-11-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
+	PR fortran/30285
+	* module.c (struct written_common, written_commons): New structure.
+	(compare_written_commons, free_written_common, write_common_0):
+	New functions.
+	(write_common): Call recursive function write_common_0.
+
+2007-11-17  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
 	PR fortran/34108
 	* io.c (check_format_string): Only check character expressions.
 	(match_dt_format): Return MATCH_ERROR if that is what

Re: [fortran,patch] Don't write common more than once in a module file (PR 30285)

[Jerry DeLisle]

FX Coudert wrote:
> PR 30285 is about deeply nested module files containing commons, which 
> take a huge amount of memory when they're read back (and loads of disk 
> space, but that's not so much of a problem). This commonly happens with 
> MPICH and openmpi, and leads some people to run out of memory when 
> compiling mpi-enabled programs.
> 
> The problem is that we write each common name more than once (a number 
> of times that grows exponentially with the nesting). I tried to change 
> the way we load modules, to avoid creating these duplicate symbols, but 
> the diagnostics code for commons with binding labels requires this 
> creation of multiple symbols, so I went for something that is a bit of a 
> hack: we get rid of duplicate common names (specificaly: duplicate pairs 
> of name and binding label) when writing the module files, by creating a 
> list of them as we go through and checking them against that list.
> 
> I agree it's not a perfect solution, but I couldn't make it work in any 
> other way (see the PR for a tentative patch), and I think it's worth 
> committing now, as it's a serious problem for our users. Regtested on 
> x86_64-linux, OK to commit?
> 
> FX
> 
> 
> 
> :ADDPATCH fortran:

Reviwed and with Heralds positive report.  OK to commit.

Jerry