[Patch, fortran] PR 25708 Reduce seeks when loading module files

[Janne Blomqvist <blomqvist dot janne at gmail dot com>]

Hi,

this patch expands a bit on the recent work done by Thomas Koenig.
Using aermod.f90 from the polyhedron benchmark suite as a test case,
the lseek() calls as reported by strace -c -f go roughly as

- trunk before Thomas' patch: 21 million

- current trunk: 5.7 million

- with attached patch: 2.7 million

As can be seen, this patch roughly halves the seeks. Of course, 2.7
million is still a ridiculously high number, but further work requires
different kind of changes, perhaps also a bit riskier, which is why
I'd like to get this in separately.

Regtested on x86_64-unknown-linux-gnu, Ok for trunk?

2011-11-30  Janne Blomqvist  <jb@gcc.gnu.org>

	PR fortran/25708
	* module.c (parse_string): Read string into resizable array
	instead of parsing twice and seeking.
	(verify_atoms): New function.
	(require_atom): Move checking to verify_atoms, call it.
	(mio_typespec): Don't peek.
	(mio_constructor): Likewise.
	(mio_typebound_proc): Likewise.
	(mio_full_typebound_tree): Likewise.
	(mio_f2k_derived): Likewise.
	(load_operator_interfaces): Likewise.
	(load_generic_interfaces): Likewise.
	(load_commons): Likewise.
	(load_equiv): Likewise.
	(load_derived_extensions): Likewise.
	(read_module): Likewise.


-- 
Janne Blomqvist

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 70f8565..982425d 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1069,51 +1069,49 @@ module_unget_char (void)
 static void
 parse_string (void)
 {
-  module_locus start;
-  int len, c;
-  char *p;
-
-  get_module_locus (&start);
+  int c;
+  size_t cursz = 30;
+  size_t len = 0;
 
-  len = 0;
+  atom_string = XNEWVEC (char, cursz);
 
-  /* See how long the string is.  */
   for ( ; ; )
     {
       c = module_char ();
-      if (c == EOF)
-	bad_module ("Unexpected end of module in string constant");
 
-      if (c != '\'')
+      if (c == '\'')
 	{
-	  len++;
-	  continue;
+	  int c2 = module_char ();
+	  if (c2 == '\'')
+	    {
+	      if (len + 1 >= cursz)
+		{
+		  cursz *= 2;
+		  atom_string = XRESIZEVEC (char, atom_string, cursz);
+		}
+	      atom_string[len] = c;
+	      len++;
+	      atom_string[len] = c2;
+	      len++;
+	    }
+	  else
+	    {
+	      module_unget_char ();
+	      break;
+	    }
 	}
 
-      c = module_char ();
-      if (c == '\'')
+      if (len >= cursz)
 	{
-	  len++;
-	  continue;
+	  cursz *= 2;
+	  atom_string = XRESIZEVEC (char, atom_string, cursz);
 	}
-
-      break;
-    }
-
-  set_module_locus (&start);
-
-  atom_string = p = XCNEWVEC (char, len + 1);
-
-  for (; len > 0; len--)
-    {
-      c = module_char ();
-      if (c == '\'')
-	module_char ();		/* Guaranteed to be another \'.  */
-      *p++ = c;
+      atom_string[len] = c;
+      len++;
     }
 
-  module_char ();		/* Terminating \'.  */
-  *p = '\0';			/* C-style string for debug purposes.  */
+  atom_string = XRESIZEVEC (char, atom_string, len + 1);
+  atom_string[len] = '\0'; 	/* C-style string for debug purposes.  */
 }
 
 
@@ -1293,22 +1291,15 @@ peek_atom (void)
 }
 
 
-/* Read the next atom from the input, requiring that it be a
-   particular kind.  */
+/* Verify that two atoms are equal, fatal error otherwise.  */
 
 static void
-require_atom (atom_type type)
+verify_atoms (atom_type got, atom_type expected)
 {
-  module_locus m;
-  atom_type t;
   const char *p;
-
-  get_module_locus (&m);
-
-  t = parse_atom ();
-  if (t != type)
+  if (got != expected)
     {
-      switch (type)
+      switch (expected)
 	{
 	case ATOM_NAME:
 	  p = _("Expected name");
@@ -1329,12 +1320,24 @@ require_atom (atom_type type)
 	  gfc_internal_error ("require_atom(): bad atom type required");
 	}
 
-      set_module_locus (&m);
       bad_module (p);
     }
 }
 
 
+/* Read the next atom from the input, requiring that it be a
+   particular kind.  */
+
+static void
+require_atom (atom_type type)
+{
+  atom_type t;
+
+  t = parse_atom ();
+  verify_atoms (t, type);
+}
+
+
 /* Given a pointer to an mstring array, require that the current input
    be one of the strings in the array.  We return the enum value.  */
 
@@ -2220,15 +2223,20 @@ mio_typespec (gfc_typespec *ts)
     {
       if (ts->type == BT_CHARACTER && ts->deferred)
 	write_atom (ATOM_NAME, "DEFERRED_CL");
+      mio_rparen ();
     }
-  else if (peek_atom () != ATOM_RPAREN)
+  else
     {
-      if (parse_atom () != ATOM_NAME)
-	bad_module ("Expected string");
-      ts->deferred = 1;
+      atom_type t = parse_atom ();
+      if (t != ATOM_RPAREN)
+	{
+	  verify_atoms (t, ATOM_NAME);
+	  ts->deferred = 1;
+	  mio_rparen ();
+	}
     }
 
-  mio_rparen ();
+
 }
 
 
@@ -2771,21 +2779,23 @@ mio_constructor (gfc_constructor_base *cp)
 	  mio_iterator (&c->iterator);
 	  mio_rparen ();
 	}
+      mio_rparen ();
     }
   else
     {
-      while (peek_atom () != ATOM_RPAREN)
+      for (;;)
 	{
+	  atom_type t = parse_atom ();
+	  if (t == ATOM_RPAREN)
+	    break;
 	  c = gfc_constructor_append_expr (cp, NULL, NULL);
 
-	  mio_lparen ();
+	  verify_atoms (t, ATOM_LPAREN);
 	  mio_expr (&c->expr);
 	  mio_iterator (&c->iterator);
 	  mio_rparen ();
 	}
     }
-
-  mio_rparen ();
 }
 
 
@@ -3477,19 +3487,25 @@ mio_typebound_proc (gfc_typebound_proc** proc)
       mio_lparen ();
 
       if (iomode == IO_OUTPUT)
-	for (g = (*proc)->u.generic; g; g = g->next)
-	  mio_allocated_string (g->specific_st->name);
+	{
+	  for (g = (*proc)->u.generic; g; g = g->next)
+	    mio_allocated_string (g->specific_st->name);
+	  mio_rparen ();
+	}
       else
 	{
 	  (*proc)->u.generic = NULL;
-	  while (peek_atom () != ATOM_RPAREN)
+	  for (;;)
 	    {
 	      gfc_symtree** sym_root;
+	      atom_type t = parse_atom ();
+	      if (t == ATOM_RPAREN)
+		break;
 
 	      g = gfc_get_tbp_generic ();
 	      g->specific = NULL;
 
-	      require_atom (ATOM_STRING);
+	      verify_atoms (t, ATOM_STRING);
 	      sym_root = &current_f2k_derived->tb_sym_root;
 	      g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
 	      free (atom_string);
@@ -3498,8 +3514,6 @@ mio_typebound_proc (gfc_typebound_proc** proc)
 	      (*proc)->u.generic = g;
 	    }
 	}
-
-      mio_rparen ();
     }
   else if (!(*proc)->ppc)
     mio_symtree_ref (&(*proc)->u.specific);
@@ -3532,24 +3546,31 @@ mio_full_typebound_tree (gfc_symtree** root)
   mio_lparen ();
 
   if (iomode == IO_OUTPUT)
-    gfc_traverse_symtree (*root, &mio_typebound_symtree);
+    {
+      gfc_traverse_symtree (*root, &mio_typebound_symtree);
+      mio_rparen ();
+    }
   else
     {
-      while (peek_atom () == ATOM_LPAREN)
+      for (;;)
 	{
 	  gfc_symtree* st;
+	  atom_type t = parse_atom ();
+	  if (t == ATOM_LPAREN)
+	    {
+	      require_atom (ATOM_STRING);
+	      st = gfc_get_tbp_symtree (root, atom_string);
+	      free (atom_string);
 
-	  mio_lparen (); 
-
-	  require_atom (ATOM_STRING);
-	  st = gfc_get_tbp_symtree (root, atom_string);
-	  free (atom_string);
-
-	  mio_typebound_symtree (st);
+	      mio_typebound_symtree (st);
+	    }
+	  else
+	    {
+	      verify_atoms (t, ATOM_RPAREN);
+	      break;
+	    }
 	}
     }
-
-  mio_rparen ();
 }
 
 static void
@@ -3622,18 +3643,21 @@ mio_f2k_derived (gfc_namespace *f2k)
 	  mio_typebound_proc (&f2k->tb_op[op]);
 	  mio_rparen ();
 	}
+      mio_rparen ();
     }
   else
-    while (peek_atom () != ATOM_RPAREN)
+    for (;;)
       {
 	gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC.  */
+	atom_type t = parse_atom ();
+	if (t == ATOM_RPAREN)
+	  break;
 
-	mio_lparen ();
+	verify_atoms (t, ATOM_LPAREN);
 	mio_intrinsic_op (&op);
 	mio_typebound_proc (&f2k->tb_op[op]);
 	mio_rparen ();
       }
-  mio_rparen ();
 }
 
 static void
@@ -3854,9 +3878,12 @@ load_operator_interfaces (void)
 
   mio_lparen ();
 
-  while (peek_atom () != ATOM_RPAREN)
+  for (;;)
     {
-      mio_lparen ();
+      atom_type t = parse_atom ();
+      if (t == ATOM_RPAREN)
+	break;
+      verify_atoms (t, ATOM_LPAREN);
 
       mio_internal_string (name);
       mio_internal_string (module);
@@ -3891,8 +3918,6 @@ load_operator_interfaces (void)
 	    }
 	}
     }
-
-  mio_rparen ();
 }
 
 
@@ -3911,9 +3936,12 @@ load_generic_interfaces (void)
 
   mio_lparen ();
 
-  while (peek_atom () != ATOM_RPAREN)
+  for (;;)
     {
-      mio_lparen ();
+      atom_type t = parse_atom ();
+      if (t == ATOM_RPAREN)
+	break;
+      verify_atoms (t, ATOM_LPAREN);
 
       mio_internal_string (name);
       mio_internal_string (module);
@@ -4036,8 +4064,6 @@ load_generic_interfaces (void)
 
 	}
     }
-
-  mio_rparen ();
 }
 
 
@@ -4051,10 +4077,14 @@ load_commons (void)
 
   mio_lparen ();
 
-  while (peek_atom () != ATOM_RPAREN)
+  for (;;)
     {
       int flags;
-      mio_lparen ();
+      atom_type t = parse_atom ();
+      if (t == ATOM_RPAREN)
+	break;
+
+      verify_atoms (t, ATOM_LPAREN);
       mio_internal_string (name);
 
       p = gfc_get_common (name, 1);
@@ -4074,8 +4104,6 @@ load_commons (void)
       
       mio_rparen ();
     }
-
-  mio_rparen ();
 }
 
 
@@ -4096,8 +4124,12 @@ load_equiv (void)
   while (end != NULL && end->next != NULL)
     end = end->next;
 
-  while (peek_atom () != ATOM_RPAREN) {
-    mio_lparen ();
+  for (;;)
+    {
+      atom_type t = parse_atom ();
+      if (t == ATOM_RPAREN)
+	break;
+      verify_atoms (t, ATOM_LPAREN);
     head = tail = NULL;
 
     while(peek_atom () != ATOM_RPAREN)
@@ -4150,8 +4182,6 @@ load_equiv (void)
 
     mio_rparen ();
   }
-
-  mio_rparen ();
   in_load_equiv = false;
 }
 
@@ -4171,9 +4201,12 @@ load_derived_extensions (void)
   const char *p;
 
   mio_lparen ();
-  while (peek_atom () != ATOM_RPAREN)
+  for (;;)
     {
-      mio_lparen ();
+      atom_type t = parse_atom ();
+      if (t == ATOM_RPAREN)
+	break;
+      verify_atoms (t, ATOM_LPAREN);
       mio_integer (&symbol);
       info = get_integer (symbol);
       derived = info->u.rsym.sym;
@@ -4190,9 +4223,12 @@ load_derived_extensions (void)
       if (derived->f2k_derived == NULL)
 	derived->f2k_derived = gfc_get_namespace (NULL, 0);
 
-      while (peek_atom () != ATOM_RPAREN)
+      for (;;)
 	{
-	  mio_lparen ();
+	  atom_type t2 = parse_atom ();
+	  if (t2 == ATOM_RPAREN)
+	    break;
+	  verify_atoms (t2, ATOM_LPAREN);
 	  mio_internal_string (name);
 	  mio_internal_string (module);
 
@@ -4215,9 +4251,7 @@ load_derived_extensions (void)
 	    }
 	  mio_rparen ();
 	}
-      mio_rparen ();
     }
-  mio_rparen ();
 }
 
 
@@ -4415,9 +4449,12 @@ read_module (void)
 
   /* Create the fixup nodes for all the symbols.  */
 
-  while (peek_atom () != ATOM_RPAREN)
+  for (;;)
     {
-      require_atom (ATOM_INTEGER);
+      atom_type t = parse_atom ();
+      if (t == ATOM_RPAREN)
+	break;
+      verify_atoms (t, ATOM_INTEGER);
       info = get_integer (atom_int);
 
       info->type = P_SYMBOL;
@@ -4469,7 +4506,6 @@ read_module (void)
 	}
     }
 
-  mio_rparen ();
 
   /* Parse the symtree lists.  This lets us mark which symbols need to
      be loaded.  Renaming is also done at this point by replacing the