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 <j...@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 = ¤t_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
