diff options
Diffstat (limited to 'gcc/fortran/module.c')
| -rw-r--r-- | gcc/fortran/module.c | 297 |
1 files changed, 295 insertions, 2 deletions
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 8b374a2..261c904 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -82,7 +82,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if you want it to be recognized. */ -#define MOD_VERSION "12" +#define MOD_VERSION "13" /* Structure that describes a position within a module file. */ @@ -3896,6 +3896,98 @@ mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp) } +static const mstring omp_declare_reduction_stmt[] = +{ + minit ("ASSIGN", 0), + minit ("CALL", 1), + minit (NULL, -1) +}; + + +static void +mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2, + gfc_namespace *ns, bool is_initializer) +{ + if (iomode == IO_OUTPUT) + { + if ((*sym1)->module == NULL) + { + (*sym1)->module = module_name; + (*sym2)->module = module_name; + } + mio_symbol_ref (sym1); + mio_symbol_ref (sym2); + if (ns->code->op == EXEC_ASSIGN) + { + mio_name (0, omp_declare_reduction_stmt); + mio_expr (&ns->code->expr1); + mio_expr (&ns->code->expr2); + } + else + { + int flag; + mio_name (1, omp_declare_reduction_stmt); + mio_symtree_ref (&ns->code->symtree); + mio_actual_arglist (&ns->code->ext.actual); + + flag = ns->code->resolved_isym != NULL; + mio_integer (&flag); + if (flag) + write_atom (ATOM_STRING, ns->code->resolved_isym->name); + else + mio_symbol_ref (&ns->code->resolved_sym); + } + } + else + { + pointer_info *p1 = mio_symbol_ref (sym1); + pointer_info *p2 = mio_symbol_ref (sym2); + gfc_symbol *sym; + gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns); + gcc_assert (p1->u.rsym.sym == NULL); + /* Add hidden symbols to the symtree. */ + pointer_info *q = get_integer (p1->u.rsym.ns); + q->u.pointer = (void *) ns; + sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns); + sym->ts = udr->ts; + sym->module = gfc_get_string (p1->u.rsym.module); + associate_integer_pointer (p1, sym); + sym->attr.omp_udr_artificial_var = 1; + gcc_assert (p2->u.rsym.sym == NULL); + sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns); + sym->ts = udr->ts; + sym->module = gfc_get_string (p2->u.rsym.module); + associate_integer_pointer (p2, sym); + sym->attr.omp_udr_artificial_var = 1; + if (mio_name (0, omp_declare_reduction_stmt) == 0) + { + ns->code = gfc_get_code (EXEC_ASSIGN); + mio_expr (&ns->code->expr1); + mio_expr (&ns->code->expr2); + } + else + { + int flag; + ns->code = gfc_get_code (EXEC_CALL); + mio_symtree_ref (&ns->code->symtree); + mio_actual_arglist (&ns->code->ext.actual); + + mio_integer (&flag); + if (flag) + { + require_atom (ATOM_STRING); + ns->code->resolved_isym = gfc_find_subroutine (atom_string); + free (atom_string); + } + else + mio_symbol_ref (&ns->code->resolved_sym); + } + ns->code->loc = gfc_current_locus; + ns->omp_udr_ns = 1; + } +} + + /* Unlike most other routines, the address of the symbol node is already fixed on input and the name/module has already been filled in. If you update the symbol format here, don't forget to update read_module @@ -4453,6 +4545,119 @@ load_derived_extensions (void) } +/* This function loads OpenMP user defined reductions. */ +static void +load_omp_udrs (void) +{ + mio_lparen (); + while (peek_atom () != ATOM_RPAREN) + { + const char *name, *newname; + char *altname; + gfc_typespec ts; + gfc_symtree *st; + gfc_omp_reduction_op rop = OMP_REDUCTION_USER; + + mio_lparen (); + mio_pool_string (&name); + mio_typespec (&ts); + if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0) + { + const char *p = name + sizeof ("operator ") - 1; + if (strcmp (p, "+") == 0) + rop = OMP_REDUCTION_PLUS; + else if (strcmp (p, "*") == 0) + rop = OMP_REDUCTION_TIMES; + else if (strcmp (p, "-") == 0) + rop = OMP_REDUCTION_MINUS; + else if (strcmp (p, ".and.") == 0) + rop = OMP_REDUCTION_AND; + else if (strcmp (p, ".or.") == 0) + rop = OMP_REDUCTION_OR; + else if (strcmp (p, ".eqv.") == 0) + rop = OMP_REDUCTION_EQV; + else if (strcmp (p, ".neqv.") == 0) + rop = OMP_REDUCTION_NEQV; + } + altname = NULL; + if (rop == OMP_REDUCTION_USER && name[0] == '.') + { + size_t len = strlen (name + 1); + altname = XALLOCAVEC (char, len); + gcc_assert (name[len] == '.'); + memcpy (altname, name + 1, len - 1); + altname[len - 1] = '\0'; + } + newname = name; + if (rop == OMP_REDUCTION_USER) + newname = find_use_name (altname ? altname : name, !!altname); + else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL) + newname = NULL; + if (newname == NULL) + { + skip_list (1); + continue; + } + if (altname && newname != altname) + { + size_t len = strlen (newname); + altname = XALLOCAVEC (char, len + 3); + altname[0] = '.'; + memcpy (altname + 1, newname, len); + altname[len + 1] = '.'; + altname[len + 2] = '\0'; + name = gfc_get_string (altname); + } + st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); + gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts); + if (udr) + { + require_atom (ATOM_INTEGER); + pointer_info *p = get_integer (atom_int); + if (strcmp (p->u.rsym.module, udr->omp_out->module)) + { + gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from " + "module %s at %L", + p->u.rsym.module, &gfc_current_locus); + gfc_error ("Previous !$OMP DECLARE REDUCTION from module " + "%s at %L", + udr->omp_out->module, &udr->where); + } + skip_list (1); + continue; + } + udr = gfc_get_omp_udr (); + udr->name = name; + udr->rop = rop; + udr->ts = ts; + udr->where = gfc_current_locus; + udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1); + udr->combiner_ns->proc_name = gfc_current_ns->proc_name; + mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, + false); + if (peek_atom () != ATOM_RPAREN) + { + udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1); + udr->initializer_ns->proc_name = gfc_current_ns->proc_name; + mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, + udr->initializer_ns, true); + } + if (st) + { + udr->next = st->n.omp_udr; + st->n.omp_udr = udr; + } + else + { + st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); + st->n.omp_udr = udr; + } + mio_rparen (); + } + mio_rparen (); +} + + /* Recursive function to traverse the pointer_info tree and load a needed symbol. We return nonzero if we load a symbol and stop the traversal, because the act of loading can alter the tree. */ @@ -4640,7 +4845,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info) static void read_module (void) { - module_locus operator_interfaces, user_operators, extensions; + module_locus operator_interfaces, user_operators, extensions, omp_udrs; const char *p; char name[GFC_MAX_SYMBOL_LEN + 1]; int i; @@ -4664,6 +4869,10 @@ read_module (void) get_module_locus (&extensions); skip_list (); + /* Skip OpenMP UDRs. */ + get_module_locus (&omp_udrs); + skip_list (); + mio_lparen (); /* Create the fixup nodes for all the symbols. */ @@ -4929,6 +5138,10 @@ read_module (void) load_commons (); load_equiv (); + /* Load OpenMP user defined reductions. */ + set_module_locus (&omp_udrs); + load_omp_udrs (); + /* At this point, we read those symbols that are needed but haven't been loaded yet. If one symbol requires another, the other gets marked as NEEDED if its previous state was UNUSED. */ @@ -5307,6 +5520,80 @@ write_symbol0 (gfc_symtree *st) } +static void +write_omp_udr (gfc_omp_udr *udr) +{ + switch (udr->rop) + { + case OMP_REDUCTION_USER: + /* Non-operators can't be used outside of the module. */ + if (udr->name[0] != '.') + return; + else + { + gfc_symtree *st; + size_t len = strlen (udr->name + 1); + char *name = XALLOCAVEC (char, len); + memcpy (name, udr->name, len - 1); + name[len - 1] = '\0'; + st = gfc_find_symtree (gfc_current_ns->uop_root, name); + /* If corresponding user operator is private, don't write + the UDR. */ + if (st != NULL) + { + gfc_user_op *uop = st->n.uop; + if (!check_access (uop->access, uop->ns->default_access)) + return; + } + } + break; + case OMP_REDUCTION_PLUS: + case OMP_REDUCTION_MINUS: + case OMP_REDUCTION_TIMES: + case OMP_REDUCTION_AND: + case OMP_REDUCTION_OR: + case OMP_REDUCTION_EQV: + case OMP_REDUCTION_NEQV: + /* If corresponding operator is private, don't write the UDR. */ + if (!check_access (gfc_current_ns->operator_access[udr->rop], + gfc_current_ns->default_access)) + return; + break; + default: + break; + } + if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS) + { + /* If derived type is private, don't write the UDR. */ + if (!gfc_check_symbol_access (udr->ts.u.derived)) + return; + } + + mio_lparen (); + mio_pool_string (&udr->name); + mio_typespec (&udr->ts); + mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false); + if (udr->initializer_ns) + mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, + udr->initializer_ns, true); + mio_rparen (); +} + + +static void +write_omp_udrs (gfc_symtree *st) +{ + if (st == NULL) + return; + + write_omp_udrs (st->left); + gfc_omp_udr *udr; + for (udr = st->n.omp_udr; udr; udr = udr->next) + write_omp_udr (udr); + write_omp_udrs (st->right); +} + + /* Type for the temporary tree used when writing secondary symbols. */ struct sorted_pointer_info @@ -5555,6 +5842,12 @@ write_module (void) write_char ('\n'); write_char ('\n'); + mio_lparen (); + write_omp_udrs (gfc_current_ns->omp_udr_root); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + /* Write symbol information. First we traverse all symbols in the primary namespace, writing those that need to be written. Sometimes writing one symbol will cause another to need to be |