[gomp] Fortran OpenMP parse tree dumper
Jakub Jelinek
jakub@redhat.com
Tue Sep 20 15:41:00 GMT 2005
On Mon, Sep 19, 2005 at 11:04:45PM +0200, Steven Bosscher wrote:
> But you're not handling them in dump-parse-tree.c, are you?
> IMHO think you should add that too before committing this.
I have already comitted the lot.
Here are the dump-parse-tree.c bits as incremental patch.
The first hunk is actually not related to OpenMP at all, regardless
of -fopenmp or -fno-openmp -fdump-parse-tree ICEs on say:
call foo
contains
subroutine foo
end subroutine
end
because subroutine foo's sym has sym->ns->proc_name==NULL.
I have visually inspected the 4 omp_parse[1-4].f90 testcases with
-fdump-parse-tree -fopenmp.
Ok for gomp?
2005-09-20 <jakub@redhat.com>
* dump-parse-tree.c (show_symtree): Don't crash if ns->proc_name
is NULL.
* dump-parse-tree.c (gfc_show_namelist, gfc_show_omp_node): New
functions.
(gfc_show_code_node): Call gfc_show_omp_node for EXEC_OMP_* nodes.
--- gcc/fortran/dump-parse-tree.c.jj 2005-09-17 20:45:46.000000000 +0200
+++ gcc/fortran/dump-parse-tree.c 2005-09-20 00:25:20.000000000 +0200
@@ -756,7 +756,10 @@ show_symtree (gfc_symtree * st)
gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
if (st->n.sym->ns != gfc_current_ns)
- gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
+ {
+ if (st->n.sym->ns->proc_name)
+ gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
+ }
else
gfc_show_symbol (st->n.sym);
}
@@ -779,6 +782,202 @@ gfc_show_code (int level, gfc_code * c)
gfc_show_code_node (level, c);
}
+static void
+gfc_show_namelist (gfc_namelist *n)
+{
+ for (; n->next; n = n->next)
+ gfc_status ("%s,", n->sym->name);
+ gfc_status ("%s", n->sym->name);
+}
+
+/* Show a single OpenMP directive node and everything underneath it
+ if necessary. */
+
+static void
+gfc_show_omp_node (int level, gfc_code * c)
+{
+ gfc_omp_clauses *omp_clauses = NULL;
+ const char *name = NULL;
+
+ switch (c->op)
+ {
+ case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
+ case EXEC_OMP_BARRIER: name = "BARRIER"; break;
+ case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
+ case EXEC_OMP_FLUSH: name = "FLUSH"; break;
+ case EXEC_OMP_DO: name = "DO"; break;
+ case EXEC_OMP_MASTER: name = "MASTER"; break;
+ case EXEC_OMP_ORDERED: name = "ORDERED"; break;
+ case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
+ case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
+ case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
+ case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
+ case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
+ case EXEC_OMP_SINGLE: name = "SINGLE"; break;
+ case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status ("!$OMP %s", name);
+ switch (c->op)
+ {
+ case EXEC_OMP_DO:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ omp_clauses = c->ext.omp_clauses;
+ break;
+ case EXEC_OMP_CRITICAL:
+ if (c->ext.omp_name)
+ gfc_status (" (%s)", c->ext.omp_name);
+ break;
+ case EXEC_OMP_FLUSH:
+ if (c->ext.omp_namelist)
+ {
+ gfc_status (" (");
+ gfc_show_namelist (c->ext.omp_namelist);
+ gfc_status_char (')');
+ }
+ return;
+ case EXEC_OMP_BARRIER:
+ return;
+ default:
+ break;
+ }
+ if (omp_clauses)
+ {
+ int list_type;
+
+ if (omp_clauses->if_expr)
+ {
+ gfc_status (" IF(");
+ gfc_show_expr (omp_clauses->if_expr);
+ gfc_status_char (')');
+ }
+ if (omp_clauses->num_threads)
+ {
+ gfc_status (" NUM_THREADS(");
+ gfc_show_expr (omp_clauses->num_threads);
+ gfc_status_char (')');
+ }
+ if (omp_clauses->sched_kind != OMP_SCHED_NONE)
+ {
+ const char *type;
+ switch (omp_clauses->sched_kind)
+ {
+ case OMP_SCHED_STATIC: type = "STATIC"; break;
+ case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
+ case OMP_SCHED_GUIDED: type = "GUIDED"; break;
+ case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" SCHEDULE (%s", type);
+ if (omp_clauses->chunk_size)
+ {
+ gfc_status_char (',');
+ gfc_show_expr (omp_clauses->chunk_size);
+ }
+ gfc_status_char (')');
+ }
+ if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
+ {
+ const char *type;
+ switch (omp_clauses->default_sharing)
+ {
+ case OMP_DEFAULT_NONE: type = "NONE"; break;
+ case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
+ case OMP_DEFAULT_SHARED: type = "SHARED"; break;
+ case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" DEFAULT(%s)", type);
+ }
+ if (omp_clauses->ordered)
+ gfc_status (" ORDERED");
+ for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
+ if (omp_clauses->lists[list_type] != NULL
+ && list_type != OMP_LIST_COPYPRIVATE)
+ {
+ const char *type;
+ if (list_type >= OMP_LIST_REDUCTION_FIRST)
+ {
+ switch (list_type)
+ {
+ case OMP_LIST_PLUS: type = "+"; break;
+ case OMP_LIST_MULT: type = "*"; break;
+ case OMP_LIST_SUB: type = "-"; break;
+ case OMP_LIST_AND: type = ".AND."; break;
+ case OMP_LIST_OR: type = ".OR."; break;
+ case OMP_LIST_EQV: type = ".EQV."; break;
+ case OMP_LIST_NEQV: type = ".NEQV."; break;
+ case OMP_LIST_MAX: type = "MAX"; break;
+ case OMP_LIST_MIN: type = "MIN"; break;
+ case OMP_LIST_IAND: type = "IAND"; break;
+ case OMP_LIST_IOR: type = "IOR"; break;
+ case OMP_LIST_IEOR: type = "IEOR"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" REDUCTION(%s:", type);
+ }
+ else
+ {
+ switch (list_type)
+ {
+ case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
+ case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+ case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
+ case OMP_LIST_SHARED: type = "SHARED"; break;
+ case OMP_LIST_COPYIN: type = "COPYIN"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" %s(", type);
+ }
+ gfc_show_namelist (omp_clauses->lists[list_type]);
+ gfc_status_char (')');
+ }
+ }
+ gfc_status_char ('\n');
+ if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
+ {
+ gfc_code *d = c->block;
+ while (d != NULL)
+ {
+ gfc_show_code (level + 1, d->next);
+ if (d->block == NULL)
+ break;
+ code_indent (level, 0);
+ gfc_status ("!$OMP SECTION\n");
+ d = d->block;
+ }
+ }
+ else
+ gfc_show_code (level + 1, c->block->next);
+ if (c->op == EXEC_OMP_ATOMIC)
+ return;
+ code_indent (level, 0);
+ gfc_status ("!$OMP END %s", name);
+ if (omp_clauses != NULL)
+ {
+ if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
+ {
+ gfc_status (" COPYPRIVATE(");
+ gfc_show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
+ gfc_status_char (')');
+ }
+ else if (omp_clauses->nowait)
+ gfc_status (" NOWAIT");
+ }
+ else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
+ gfc_status (" (%s)", c->ext.omp_name);
+}
/* Show a single code node and everything underneath it if necessary. */
@@ -1426,6 +1625,23 @@ gfc_show_code_node (int level, gfc_code
gfc_status (" EOR=%d", dt->eor->value);
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_FLUSH:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ gfc_show_omp_node (level, c);
+ break;
+
default:
gfc_internal_error ("gfc_show_code_node(): Bad statement code");
}
Jakub
More information about the Fortran
mailing list