| /* Pass manager for Fortran front end. |
| Copyright (C) 2010-2021 Free Software Foundation, Inc. |
| Contributed by Thomas König. |
| |
| This file is part of GCC. |
| |
| GCC is free software; you can redistribute it and/or modify it under |
| the terms of the GNU General Public License as published by the Free |
| Software Foundation; either version 3, or (at your option) any later |
| version. |
| |
| GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GCC; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "options.h" |
| #include "gfortran.h" |
| #include "dependency.h" |
| #include "constructor.h" |
| #include "intrinsic.h" |
| |
| /* Forward declarations. */ |
| |
| static void strip_function_call (gfc_expr *); |
| static void optimize_namespace (gfc_namespace *); |
| static void optimize_assignment (gfc_code *); |
| static bool optimize_op (gfc_expr *); |
| static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op); |
| static bool optimize_trim (gfc_expr *); |
| static bool optimize_lexical_comparison (gfc_expr *); |
| static void optimize_minmaxloc (gfc_expr **); |
| static bool is_empty_string (gfc_expr *e); |
| static void doloop_warn (gfc_namespace *); |
| static int do_intent (gfc_expr **); |
| static int do_subscript (gfc_expr **); |
| static void optimize_reduction (gfc_namespace *); |
| static int callback_reduction (gfc_expr **, int *, void *); |
| static void realloc_strings (gfc_namespace *); |
| static gfc_expr *create_var (gfc_expr *, const char *vname=NULL); |
| static int matmul_to_var_expr (gfc_expr **, int *, void *); |
| static int matmul_to_var_code (gfc_code **, int *, void *); |
| static int inline_matmul_assign (gfc_code **, int *, void *); |
| static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *, |
| locus *, gfc_namespace *, |
| char *vname=NULL); |
| static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *, |
| bool *); |
| static int call_external_blas (gfc_code **, int *, void *); |
| static int matmul_temp_args (gfc_code **, int *,void *data); |
| static int index_interchange (gfc_code **, int*, void *); |
| static bool is_fe_temp (gfc_expr *e); |
| |
| #ifdef CHECKING_P |
| static void check_locus (gfc_namespace *); |
| #endif |
| |
| /* How deep we are inside an argument list. */ |
| |
| static int count_arglist; |
| |
| /* Vector of gfc_expr ** we operate on. */ |
| |
| static vec<gfc_expr **> expr_array; |
| |
| /* Pointer to the gfc_code we currently work on - to be able to insert |
| a block before the statement. */ |
| |
| static gfc_code **current_code; |
| |
| /* Pointer to the block to be inserted, and the statement we are |
| changing within the block. */ |
| |
| static gfc_code *inserted_block, **changed_statement; |
| |
| /* The namespace we are currently dealing with. */ |
| |
| static gfc_namespace *current_ns; |
| |
| /* If we are within any forall loop. */ |
| |
| static int forall_level; |
| |
| /* Keep track of whether we are within an OMP workshare. */ |
| |
| static bool in_omp_workshare; |
| |
| /* Keep track of whether we are within an OMP atomic. */ |
| |
| static bool in_omp_atomic; |
| |
| /* Keep track of whether we are within a WHERE statement. */ |
| |
| static bool in_where; |
| |
| /* Keep track of iterators for array constructors. */ |
| |
| static int iterator_level; |
| |
| /* Keep track of DO loop levels. */ |
| |
| typedef struct { |
| gfc_code *c; |
| int branch_level; |
| bool seen_goto; |
| } do_t; |
| |
| static vec<do_t> doloop_list; |
| static int doloop_level; |
| |
| /* Keep track of if and select case levels. */ |
| |
| static int if_level; |
| static int select_level; |
| |
| /* Vector of gfc_expr * to keep track of DO loops. */ |
| |
| struct my_struct *evec; |
| |
| /* Keep track of association lists. */ |
| |
| static bool in_assoc_list; |
| |
| /* Counter for temporary variables. */ |
| |
| static int var_num = 1; |
| |
| /* What sort of matrix we are dealing with when inlining MATMUL. */ |
| |
| enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T }; |
| |
| /* Keep track of the number of expressions we have inserted so far |
| using create_var. */ |
| |
| int n_vars; |
| |
| /* Entry point - run all passes for a namespace. */ |
| |
| void |
| gfc_run_passes (gfc_namespace *ns) |
| { |
| |
| /* Warn about dubious DO loops where the index might |
| change. */ |
| |
| doloop_level = 0; |
| if_level = 0; |
| select_level = 0; |
| doloop_warn (ns); |
| doloop_list.release (); |
| int w, e; |
| |
| #ifdef CHECKING_P |
| check_locus (ns); |
| #endif |
| |
| gfc_get_errors (&w, &e); |
| if (e > 0) |
| return; |
| |
| if (flag_frontend_optimize || flag_frontend_loop_interchange) |
| optimize_namespace (ns); |
| |
| if (flag_frontend_optimize) |
| { |
| optimize_reduction (ns); |
| if (flag_dump_fortran_optimized) |
| gfc_dump_parse_tree (ns, stdout); |
| |
| expr_array.release (); |
| } |
| |
| if (flag_realloc_lhs) |
| realloc_strings (ns); |
| } |
| |
| #ifdef CHECKING_P |
| |
| /* Callback function: Warn if there is no location information in a |
| statement. */ |
| |
| static int |
| check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| current_code = c; |
| if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL))) |
| gfc_warning_internal (0, "Inconsistent internal state: " |
| "No location in statement"); |
| |
| return 0; |
| } |
| |
| |
| /* Callback function: Warn if there is no location information in an |
| expression. */ |
| |
| static int |
| check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| |
| if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL))) |
| gfc_warning_internal (0, "Inconsistent internal state: " |
| "No location in expression near %L", |
| &((*current_code)->loc)); |
| return 0; |
| } |
| |
| /* Run check for missing location information. */ |
| |
| static void |
| check_locus (gfc_namespace *ns) |
| { |
| gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL); |
| |
| for (ns = ns->contained; ns; ns = ns->sibling) |
| { |
| if (ns->code == NULL || ns->code->op != EXEC_BLOCK) |
| check_locus (ns); |
| } |
| } |
| |
| #endif |
| |
| /* Callback for each gfc_code node invoked from check_realloc_strings. |
| For an allocatable LHS string which also appears as a variable on |
| the RHS, replace |
| |
| a = a(x:y) |
| |
| with |
| |
| tmp = a(x:y) |
| a = tmp |
| */ |
| |
| static int |
| realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_expr *expr1, *expr2; |
| gfc_code *co = *c; |
| gfc_expr *n; |
| gfc_ref *ref; |
| bool found_substr; |
| |
| if (co->op != EXEC_ASSIGN) |
| return 0; |
| |
| expr1 = co->expr1; |
| if (expr1->ts.type != BT_CHARACTER |
| || !gfc_expr_attr(expr1).allocatable |
| || !expr1->ts.deferred) |
| return 0; |
| |
| if (is_fe_temp (expr1)) |
| return 0; |
| |
| expr2 = gfc_discard_nops (co->expr2); |
| |
| if (expr2->expr_type == EXPR_VARIABLE) |
| { |
| found_substr = false; |
| for (ref = expr2->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_SUBSTRING) |
| { |
| found_substr = true; |
| break; |
| } |
| } |
| if (!found_substr) |
| return 0; |
| } |
| else if (expr2->expr_type != EXPR_ARRAY |
| && (expr2->expr_type != EXPR_OP |
| || expr2->value.op.op != INTRINSIC_CONCAT)) |
| return 0; |
| |
| if (!gfc_check_dependency (expr1, expr2, true)) |
| return 0; |
| |
| /* gfc_check_dependency doesn't always pick up identical expressions. |
| However, eliminating the above sends the compiler into an infinite |
| loop on valid expressions. Without this check, the gimplifier emits |
| an ICE for a = a, where a is deferred character length. */ |
| if (!gfc_dep_compare_expr (expr1, expr2)) |
| return 0; |
| |
| current_code = c; |
| inserted_block = NULL; |
| changed_statement = NULL; |
| n = create_var (expr2, "realloc_string"); |
| co->expr2 = n; |
| return 0; |
| } |
| |
| /* Callback for each gfc_code node invoked through gfc_code_walker |
| from optimize_namespace. */ |
| |
| static int |
| optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| |
| gfc_exec_op op; |
| |
| op = (*c)->op; |
| |
| if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL |
| || op == EXEC_CALL_PPC) |
| count_arglist = 1; |
| else |
| count_arglist = 0; |
| |
| current_code = c; |
| inserted_block = NULL; |
| changed_statement = NULL; |
| |
| if (op == EXEC_ASSIGN) |
| optimize_assignment (*c); |
| return 0; |
| } |
| |
| /* Callback for each gfc_expr node invoked through gfc_code_walker |
| from optimize_namespace. */ |
| |
| static int |
| optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| bool function_expr; |
| |
| if ((*e)->expr_type == EXPR_FUNCTION) |
| { |
| count_arglist ++; |
| function_expr = true; |
| } |
| else |
| function_expr = false; |
| |
| if (optimize_trim (*e)) |
| gfc_simplify_expr (*e, 0); |
| |
| if (optimize_lexical_comparison (*e)) |
| gfc_simplify_expr (*e, 0); |
| |
| if ((*e)->expr_type == EXPR_OP && optimize_op (*e)) |
| gfc_simplify_expr (*e, 0); |
| |
| if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym) |
| switch ((*e)->value.function.isym->id) |
| { |
| case GFC_ISYM_MINLOC: |
| case GFC_ISYM_MAXLOC: |
| optimize_minmaxloc (e); |
| break; |
| default: |
| break; |
| } |
| |
| if (function_expr) |
| count_arglist --; |
| |
| return 0; |
| } |
| |
| /* Auxiliary function to handle the arguments to reduction intrinsics. If the |
| function is a scalar, just copy it; otherwise returns the new element, the |
| old one can be freed. */ |
| |
| static gfc_expr * |
| copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn) |
| { |
| gfc_expr *fcn, *e = c->expr; |
| |
| fcn = gfc_copy_expr (e); |
| if (c->iterator) |
| { |
| gfc_constructor_base newbase; |
| gfc_expr *new_expr; |
| gfc_constructor *new_c; |
| |
| newbase = NULL; |
| new_expr = gfc_get_expr (); |
| new_expr->expr_type = EXPR_ARRAY; |
| new_expr->ts = e->ts; |
| new_expr->where = e->where; |
| new_expr->rank = 1; |
| new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where)); |
| new_c->iterator = c->iterator; |
| new_expr->value.constructor = newbase; |
| c->iterator = NULL; |
| |
| fcn = new_expr; |
| } |
| |
| if (fcn->rank != 0) |
| { |
| gfc_isym_id id = fn->value.function.isym->id; |
| |
| if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) |
| fcn = gfc_build_intrinsic_call (current_ns, id, |
| fn->value.function.isym->name, |
| fn->where, 3, fcn, NULL, NULL); |
| else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL) |
| fcn = gfc_build_intrinsic_call (current_ns, id, |
| fn->value.function.isym->name, |
| fn->where, 2, fcn, NULL); |
| else |
| gfc_internal_error ("Illegal id in copy_walk_reduction_arg"); |
| |
| fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; |
| } |
| |
| return fcn; |
| } |
| |
| /* Callback function for optimzation of reductions to scalars. Transform ANY |
| ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT |
| correspondingly. Handly only the simple cases without MASK and DIM. */ |
| |
| static int |
| callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_expr *fn, *arg; |
| gfc_intrinsic_op op; |
| gfc_isym_id id; |
| gfc_actual_arglist *a; |
| gfc_actual_arglist *dim; |
| gfc_constructor *c; |
| gfc_expr *res, *new_expr; |
| gfc_actual_arglist *mask; |
| |
| fn = *e; |
| |
| if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION |
| || fn->value.function.isym == NULL) |
| return 0; |
| |
| id = fn->value.function.isym->id; |
| |
| if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT |
| && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL) |
| return 0; |
| |
| a = fn->value.function.actual; |
| |
| /* Don't handle MASK or DIM. */ |
| |
| dim = a->next; |
| |
| if (dim->expr != NULL) |
| return 0; |
| |
| if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) |
| { |
| mask = dim->next; |
| if ( mask->expr != NULL) |
| return 0; |
| } |
| |
| arg = a->expr; |
| |
| if (arg->expr_type != EXPR_ARRAY) |
| return 0; |
| |
| switch (id) |
| { |
| case GFC_ISYM_SUM: |
| op = INTRINSIC_PLUS; |
| break; |
| |
| case GFC_ISYM_PRODUCT: |
| op = INTRINSIC_TIMES; |
| break; |
| |
| case GFC_ISYM_ANY: |
| op = INTRINSIC_OR; |
| break; |
| |
| case GFC_ISYM_ALL: |
| op = INTRINSIC_AND; |
| break; |
| |
| default: |
| return 0; |
| } |
| |
| c = gfc_constructor_first (arg->value.constructor); |
| |
| /* Don't do any simplififcation if we have |
| - no element in the constructor or |
| - only have a single element in the array which contains an |
| iterator. */ |
| |
| if (c == NULL) |
| return 0; |
| |
| res = copy_walk_reduction_arg (c, fn); |
| |
| c = gfc_constructor_next (c); |
| while (c) |
| { |
| new_expr = gfc_get_expr (); |
| new_expr->ts = fn->ts; |
| new_expr->expr_type = EXPR_OP; |
| new_expr->rank = fn->rank; |
| new_expr->where = fn->where; |
| new_expr->value.op.op = op; |
| new_expr->value.op.op1 = res; |
| new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn); |
| res = new_expr; |
| c = gfc_constructor_next (c); |
| } |
| |
| gfc_simplify_expr (res, 0); |
| *e = res; |
| gfc_free_expr (fn); |
| |
| return 0; |
| } |
| |
| /* Callback function for common function elimination, called from cfe_expr_0. |
| Put all eligible function expressions into expr_array. */ |
| |
| static int |
| cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| |
| if ((*e)->expr_type != EXPR_FUNCTION) |
| return 0; |
| |
| /* We don't do character functions with unknown charlens. */ |
| if ((*e)->ts.type == BT_CHARACTER |
| && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL |
| || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT)) |
| return 0; |
| |
| /* We don't do function elimination within FORALL statements, it can |
| lead to wrong-code in certain circumstances. */ |
| |
| if (forall_level > 0) |
| return 0; |
| |
| /* Function elimination inside an iterator could lead to functions which |
| depend on iterator variables being moved outside. FIXME: We should check |
| if the functions do indeed depend on the iterator variable. */ |
| |
| if (iterator_level > 0) |
| return 0; |
| |
| /* If we don't know the shape at compile time, we create an allocatable |
| temporary variable to hold the intermediate result, but only if |
| allocation on assignment is active. */ |
| |
| if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs) |
| return 0; |
| |
| /* Skip the test for pure functions if -faggressive-function-elimination |
| is specified. */ |
| if ((*e)->value.function.esym) |
| { |
| /* Don't create an array temporary for elemental functions. */ |
| if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0) |
| return 0; |
| |
| /* Only eliminate potentially impure functions if the |
| user specifically requested it. */ |
| if (!flag_aggressive_function_elimination |
| && !(*e)->value.function.esym->attr.pure |
| && !(*e)->value.function.esym->attr.implicit_pure) |
| return 0; |
| } |
| |
| if ((*e)->value.function.isym) |
| { |
| /* Conversions are handled on the fly by the middle end, |
| transpose during trans-* stages and TRANSFER by the middle end. */ |
| if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION |
| || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER |
| || gfc_inline_intrinsic_function_p (*e)) |
| return 0; |
| |
| /* Don't create an array temporary for elemental functions, |
| as this would be wasteful of memory. |
| FIXME: Create a scalar temporary during scalarization. */ |
| if ((*e)->value.function.isym->elemental && (*e)->rank > 0) |
| return 0; |
| |
| if (!(*e)->value.function.isym->pure) |
| return 0; |
| } |
| |
| expr_array.safe_push (e); |
| return 0; |
| } |
| |
| /* Auxiliary function to check if an expression is a temporary created by |
| create var. */ |
| |
| static bool |
| is_fe_temp (gfc_expr *e) |
| { |
| if (e->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| return e->symtree->n.sym->attr.fe_temp; |
| } |
| |
| /* Determine the length of a string, if it can be evaluated as a constant |
| expression. Return a newly allocated gfc_expr or NULL on failure. |
| If the user specified a substring which is potentially longer than |
| the string itself, the string will be padded with spaces, which |
| is harmless. */ |
| |
| static gfc_expr * |
| constant_string_length (gfc_expr *e) |
| { |
| |
| gfc_expr *length; |
| gfc_ref *ref; |
| gfc_expr *res; |
| mpz_t value; |
| |
| if (e->ts.u.cl) |
| { |
| length = e->ts.u.cl->length; |
| if (length && length->expr_type == EXPR_CONSTANT) |
| return gfc_copy_expr(length); |
| } |
| |
| /* See if there is a substring. If it has a constant length, return |
| that and NULL otherwise. */ |
| for (ref = e->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_SUBSTRING) |
| { |
| if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value)) |
| { |
| res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, |
| &e->where); |
| |
| mpz_add_ui (res->value.integer, value, 1); |
| mpz_clear (value); |
| return res; |
| } |
| else |
| return NULL; |
| } |
| } |
| |
| /* Return length of char symbol, if constant. */ |
| if (e->symtree && e->symtree->n.sym->ts.u.cl |
| && e->symtree->n.sym->ts.u.cl->length |
| && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
| return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length); |
| |
| return NULL; |
| |
| } |
| |
| /* Insert a block at the current position unless it has already |
| been inserted; in this case use the one already there. */ |
| |
| static gfc_namespace* |
| insert_block () |
| { |
| gfc_namespace *ns; |
| |
| /* If the block hasn't already been created, do so. */ |
| if (inserted_block == NULL) |
| { |
| inserted_block = XCNEW (gfc_code); |
| inserted_block->op = EXEC_BLOCK; |
| inserted_block->loc = (*current_code)->loc; |
| ns = gfc_build_block_ns (current_ns); |
| inserted_block->ext.block.ns = ns; |
| inserted_block->ext.block.assoc = NULL; |
| |
| ns->code = *current_code; |
| |
| /* If the statement has a label, make sure it is transferred to |
| the newly created block. */ |
| |
| if ((*current_code)->here) |
| { |
| inserted_block->here = (*current_code)->here; |
| (*current_code)->here = NULL; |
| } |
| |
| inserted_block->next = (*current_code)->next; |
| changed_statement = &(inserted_block->ext.block.ns->code); |
| (*current_code)->next = NULL; |
| /* Insert the BLOCK at the right position. */ |
| *current_code = inserted_block; |
| ns->parent = current_ns; |
| } |
| else |
| ns = inserted_block->ext.block.ns; |
| |
| return ns; |
| } |
| |
| |
| /* Insert a call to the intrinsic len. Use a different name for |
| the symbol tree so we don't run into trouble when the user has |
| renamed len for some reason. */ |
| |
| static gfc_expr* |
| get_len_call (gfc_expr *str) |
| { |
| gfc_expr *fcn; |
| gfc_actual_arglist *actual_arglist; |
| |
| fcn = gfc_get_expr (); |
| fcn->expr_type = EXPR_FUNCTION; |
| fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN); |
| actual_arglist = gfc_get_actual_arglist (); |
| actual_arglist->expr = str; |
| |
| fcn->value.function.actual = actual_arglist; |
| fcn->where = str->where; |
| fcn->ts.type = BT_INTEGER; |
| fcn->ts.kind = gfc_charlen_int_kind; |
| |
| gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false); |
| fcn->symtree->n.sym->ts = fcn->ts; |
| fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; |
| fcn->symtree->n.sym->attr.function = 1; |
| fcn->symtree->n.sym->attr.elemental = 1; |
| fcn->symtree->n.sym->attr.referenced = 1; |
| fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; |
| gfc_commit_symbol (fcn->symtree->n.sym); |
| |
| return fcn; |
| } |
| |
| |
| /* Returns a new expression (a variable) to be used in place of the old one, |
| with an optional assignment statement before the current statement to set |
| the value of the variable. Creates a new BLOCK for the statement if that |
| hasn't already been done and puts the statement, plus the newly created |
| variables, in that block. Special cases: If the expression is constant or |
| a temporary which has already been created, just copy it. */ |
| |
| static gfc_expr* |
| create_var (gfc_expr * e, const char *vname) |
| { |
| char name[GFC_MAX_SYMBOL_LEN +1]; |
| gfc_symtree *symtree; |
| gfc_symbol *symbol; |
| gfc_expr *result; |
| gfc_code *n; |
| gfc_namespace *ns; |
| int i; |
| bool deferred; |
| |
| if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e)) |
| return gfc_copy_expr (e); |
| |
| /* Creation of an array of unknown size requires realloc on assignment. |
| If that is not possible, just return NULL. */ |
| if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL) |
| return NULL; |
| |
| ns = insert_block (); |
| |
| if (vname) |
| snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname); |
| else |
| snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++); |
| |
| if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) |
| gcc_unreachable (); |
| |
| symbol = symtree->n.sym; |
| symbol->ts = e->ts; |
| |
| if (e->rank > 0) |
| { |
| symbol->as = gfc_get_array_spec (); |
| symbol->as->rank = e->rank; |
| |
| if (e->shape == NULL) |
| { |
| /* We don't know the shape at compile time, so we use an |
| allocatable. */ |
| symbol->as->type = AS_DEFERRED; |
| symbol->attr.allocatable = 1; |
| } |
| else |
| { |
| symbol->as->type = AS_EXPLICIT; |
| /* Copy the shape. */ |
| for (i=0; i<e->rank; i++) |
| { |
| gfc_expr *p, *q; |
| |
| p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, |
| &(e->where)); |
| mpz_set_si (p->value.integer, 1); |
| symbol->as->lower[i] = p; |
| |
| q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, |
| &(e->where)); |
| mpz_set (q->value.integer, e->shape[i]); |
| symbol->as->upper[i] = q; |
| } |
| } |
| } |
| |
| deferred = 0; |
| if (e->ts.type == BT_CHARACTER) |
| { |
| gfc_expr *length; |
| |
| symbol->ts.u.cl = gfc_new_charlen (ns, NULL); |
| length = constant_string_length (e); |
| if (length) |
| symbol->ts.u.cl->length = length; |
| else if (e->expr_type == EXPR_VARIABLE |
| && e->symtree->n.sym->ts.type == BT_CHARACTER |
| && e->ts.u.cl->length) |
| symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e)); |
| else |
| { |
| symbol->attr.allocatable = 1; |
| symbol->ts.u.cl->length = NULL; |
| symbol->ts.deferred = 1; |
| deferred = 1; |
| } |
| } |
| |
| symbol->attr.flavor = FL_VARIABLE; |
| symbol->attr.referenced = 1; |
| symbol->attr.dimension = e->rank > 0; |
| symbol->attr.fe_temp = 1; |
| gfc_commit_symbol (symbol); |
| |
| result = gfc_get_expr (); |
| result->expr_type = EXPR_VARIABLE; |
| result->ts = symbol->ts; |
| result->ts.deferred = deferred; |
| result->rank = e->rank; |
| result->shape = gfc_copy_shape (e->shape, e->rank); |
| result->symtree = symtree; |
| result->where = e->where; |
| if (e->rank > 0) |
| { |
| result->ref = gfc_get_ref (); |
| result->ref->type = REF_ARRAY; |
| result->ref->u.ar.type = AR_FULL; |
| result->ref->u.ar.where = e->where; |
| result->ref->u.ar.dimen = e->rank; |
| result->ref->u.ar.as = symbol->ts.type == BT_CLASS |
| ? CLASS_DATA (symbol)->as : symbol->as; |
| if (warn_array_temporaries) |
| gfc_warning (OPT_Warray_temporaries, |
| "Creating array temporary at %L", &(e->where)); |
| } |
| |
| /* Generate the new assignment. */ |
| n = XCNEW (gfc_code); |
| n->op = EXEC_ASSIGN; |
| n->loc = (*current_code)->loc; |
| n->next = *changed_statement; |
| n->expr1 = gfc_copy_expr (result); |
| n->expr2 = e; |
| *changed_statement = n; |
| n_vars ++; |
| |
| return result; |
| } |
| |
| /* Warn about function elimination. */ |
| |
| static void |
| do_warn_function_elimination (gfc_expr *e) |
| { |
| const char *name; |
| if (e->expr_type == EXPR_FUNCTION |
| && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e)) |
| { |
| if (name) |
| gfc_warning (OPT_Wfunction_elimination, |
| "Removing call to impure function %qs at %L", name, |
| &(e->where)); |
| else |
| gfc_warning (OPT_Wfunction_elimination, |
| "Removing call to impure function at %L", |
| &(e->where)); |
| } |
| } |
| |
| |
| /* Callback function for the code walker for doing common function |
| elimination. This builds up the list of functions in the expression |
| and goes through them to detect duplicates, which it then replaces |
| by variables. */ |
| |
| static int |
| cfe_expr_0 (gfc_expr **e, int *walk_subtrees, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| int i,j; |
| gfc_expr *newvar; |
| gfc_expr **ei, **ej; |
| |
| /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */ |
| |
| if (in_omp_workshare || in_omp_atomic || in_assoc_list) |
| { |
| *walk_subtrees = 0; |
| return 0; |
| } |
| |
| expr_array.release (); |
| |
| gfc_expr_walker (e, cfe_register_funcs, NULL); |
| |
| /* Walk through all the functions. */ |
| |
| FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1) |
| { |
| /* Skip if the function has been replaced by a variable already. */ |
| if ((*ei)->expr_type == EXPR_VARIABLE) |
| continue; |
| |
| newvar = NULL; |
| for (j=0; j<i; j++) |
| { |
| ej = expr_array[j]; |
| if (gfc_dep_compare_functions (*ei, *ej, true) == 0) |
| { |
| if (newvar == NULL) |
| newvar = create_var (*ei, "fcn"); |
| |
| if (warn_function_elimination) |
| do_warn_function_elimination (*ej); |
| |
| free (*ej); |
| *ej = gfc_copy_expr (newvar); |
| } |
| } |
| if (newvar) |
| *ei = newvar; |
| } |
| |
| /* We did all the necessary walking in this function. */ |
| *walk_subtrees = 0; |
| return 0; |
| } |
| |
| /* Callback function for common function elimination, called from |
| gfc_code_walker. This keeps track of the current code, in order |
| to insert statements as needed. */ |
| |
| static int |
| cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) |
| { |
| current_code = c; |
| inserted_block = NULL; |
| changed_statement = NULL; |
| |
| /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs |
| and allocation on assigment are prohibited inside WHERE, and finally |
| masking an expression would lead to wrong-code when replacing |
| |
| WHERE (a>0) |
| b = sum(foo(a) + foo(a)) |
| END WHERE |
| |
| with |
| |
| WHERE (a > 0) |
| tmp = foo(a) |
| b = sum(tmp + tmp) |
| END WHERE |
| */ |
| |
| if ((*c)->op == EXEC_WHERE) |
| { |
| *walk_subtrees = 0; |
| return 0; |
| } |
| |
| |
| return 0; |
| } |
| |
| /* Dummy function for expression call back, for use when we |
| really don't want to do any walking. */ |
| |
| static int |
| dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| *walk_subtrees = 0; |
| return 0; |
| } |
| |
| /* Dummy function for code callback, for use when we really |
| don't want to do anything. */ |
| int |
| gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED, |
| int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| return 0; |
| } |
| |
| /* Code callback function for converting |
| do while(a) |
| end do |
| into the equivalent |
| do |
| if (.not. a) exit |
| end do |
| This is because common function elimination would otherwise place the |
| temporary variables outside the loop. */ |
| |
| static int |
| convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_code *co = *c; |
| gfc_code *c_if1, *c_if2, *c_exit; |
| gfc_code *loopblock; |
| gfc_expr *e_not, *e_cond; |
| |
| if (co->op != EXEC_DO_WHILE) |
| return 0; |
| |
| if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT) |
| return 0; |
| |
| e_cond = co->expr1; |
| |
| /* Generate the condition of the if statement, which is .not. the original |
| statement. */ |
| e_not = gfc_get_expr (); |
| e_not->ts = e_cond->ts; |
| e_not->where = e_cond->where; |
| e_not->expr_type = EXPR_OP; |
| e_not->value.op.op = INTRINSIC_NOT; |
| e_not->value.op.op1 = e_cond; |
| |
| /* Generate the EXIT statement. */ |
| c_exit = XCNEW (gfc_code); |
| c_exit->op = EXEC_EXIT; |
| c_exit->ext.which_construct = co; |
| c_exit->loc = co->loc; |
| |
| /* Generate the IF statement. */ |
| c_if2 = XCNEW (gfc_code); |
| c_if2->op = EXEC_IF; |
| c_if2->expr1 = e_not; |
| c_if2->next = c_exit; |
| c_if2->loc = co->loc; |
| |
| /* ... plus the one to chain it to. */ |
| c_if1 = XCNEW (gfc_code); |
| c_if1->op = EXEC_IF; |
| c_if1->block = c_if2; |
| c_if1->loc = co->loc; |
| |
| /* Make the DO WHILE loop into a DO block by replacing the condition |
| with a true constant. */ |
| co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true); |
| |
| /* Hang the generated if statement into the loop body. */ |
| |
| loopblock = co->block->next; |
| co->block->next = c_if1; |
| c_if1->next = loopblock; |
| |
| return 0; |
| } |
| |
| /* Code callback function for converting |
| if (a) then |
| ... |
| else if (b) then |
| end if |
| |
| into |
| if (a) then |
| else |
| if (b) then |
| end if |
| end if |
| |
| because otherwise common function elimination would place the BLOCKs |
| into the wrong place. */ |
| |
| static int |
| convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_code *co = *c; |
| gfc_code *c_if1, *c_if2, *else_stmt; |
| |
| if (co->op != EXEC_IF) |
| return 0; |
| |
| /* This loop starts out with the first ELSE statement. */ |
| else_stmt = co->block->block; |
| |
| while (else_stmt != NULL) |
| { |
| gfc_code *next_else; |
| |
| /* If there is no condition, we're done. */ |
| if (else_stmt->expr1 == NULL) |
| break; |
| |
| next_else = else_stmt->block; |
| |
| /* Generate the new IF statement. */ |
| c_if2 = XCNEW (gfc_code); |
| c_if2->op = EXEC_IF; |
| c_if2->expr1 = else_stmt->expr1; |
| c_if2->next = else_stmt->next; |
| c_if2->loc = else_stmt->loc; |
| c_if2->block = next_else; |
| |
| /* ... plus the one to chain it to. */ |
| c_if1 = XCNEW (gfc_code); |
| c_if1->op = EXEC_IF; |
| c_if1->block = c_if2; |
| c_if1->loc = else_stmt->loc; |
| |
| /* Insert the new IF after the ELSE. */ |
| else_stmt->expr1 = NULL; |
| else_stmt->next = c_if1; |
| else_stmt->block = NULL; |
| |
| else_stmt = next_else; |
| } |
| /* Don't walk subtrees. */ |
| return 0; |
| } |
| |
| /* Callback function to var_in_expr - return true if expr1 and |
| expr2 are identical variables. */ |
| static int |
| var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data) |
| { |
| gfc_expr *expr1 = (gfc_expr *) data; |
| gfc_expr *expr2 = *e; |
| |
| if (expr2->expr_type != EXPR_VARIABLE) |
| return 0; |
| |
| return expr1->symtree->n.sym == expr2->symtree->n.sym; |
| } |
| |
| /* Return true if expr1 is found in expr2. */ |
| |
| static bool |
| var_in_expr (gfc_expr *expr1, gfc_expr *expr2) |
| { |
| gcc_assert (expr1->expr_type == EXPR_VARIABLE); |
| |
| return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1); |
| } |
| |
| struct do_stack |
| { |
| struct do_stack *prev; |
| gfc_iterator *iter; |
| gfc_code *code; |
| } *stack_top; |
| |
| /* Recursively traverse the block of a WRITE or READ statement, and maybe |
| optimize by replacing do loops with their analog array slices. For |
| example: |
| |
| write (*,*) (a(i), i=1,4) |
| |
| is replaced with |
| |
| write (*,*) a(1:4:1) . */ |
| |
| static bool |
| traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev) |
| { |
| gfc_code *curr; |
| gfc_expr *new_e, *expr, *start; |
| gfc_ref *ref; |
| struct do_stack ds_push; |
| int i, future_rank = 0; |
| gfc_iterator *iters[GFC_MAX_DIMENSIONS]; |
| gfc_expr *e; |
| |
| /* Find the first transfer/do statement. */ |
| for (curr = code; curr; curr = curr->next) |
| { |
| if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER) |
| break; |
| } |
| |
| /* Ensure it is the only transfer/do statement because cases like |
| |
| write (*,*) (a(i), b(i), i=1,4) |
| |
| cannot be optimized. */ |
| |
| if (!curr || curr->next) |
| return false; |
| |
| if (curr->op == EXEC_DO) |
| { |
| if (curr->ext.iterator->var->ref) |
| return false; |
| ds_push.prev = stack_top; |
| ds_push.iter = curr->ext.iterator; |
| ds_push.code = curr; |
| stack_top = &ds_push; |
| if (traverse_io_block (curr->block->next, has_reached, prev)) |
| { |
| if (curr != stack_top->code && !*has_reached) |
| { |
| curr->block->next = NULL; |
| gfc_free_statements (curr); |
| } |
| else |
| *has_reached = true; |
| return true; |
| } |
| return false; |
| } |
| |
| gcc_assert (curr->op == EXEC_TRANSFER); |
| |
| e = curr->expr1; |
| ref = e->ref; |
| if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next) |
| return false; |
| |
| /* Find the iterators belonging to each variable and check conditions. */ |
| for (i = 0; i < ref->u.ar.dimen; i++) |
| { |
| if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref |
| || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) |
| return false; |
| |
| start = ref->u.ar.start[i]; |
| gfc_simplify_expr (start, 0); |
| switch (start->expr_type) |
| { |
| case EXPR_VARIABLE: |
| |
| /* write (*,*) (a(i), i=a%b,1) not handled yet. */ |
| if (start->ref) |
| return false; |
| |
| /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */ |
| if (!stack_top || !stack_top->iter |
| || stack_top->iter->var->symtree != start->symtree) |
| { |
| /* Check for (a(i,i), i=1,3). */ |
| int j; |
| |
| for (j=0; j<i; j++) |
| if (iters[j] && iters[j]->var->symtree == start->symtree) |
| return false; |
| |
| iters[i] = NULL; |
| } |
| else |
| { |
| iters[i] = stack_top->iter; |
| stack_top = stack_top->prev; |
| future_rank++; |
| } |
| break; |
| case EXPR_CONSTANT: |
| iters[i] = NULL; |
| break; |
| case EXPR_OP: |
| switch (start->value.op.op) |
| { |
| case INTRINSIC_PLUS: |
| case INTRINSIC_TIMES: |
| if (start->value.op.op1->expr_type != EXPR_VARIABLE) |
| std::swap (start->value.op.op1, start->value.op.op2); |
| gcc_fallthrough (); |
| case INTRINSIC_MINUS: |
| if (start->value.op.op1->expr_type!= EXPR_VARIABLE |
| || start->value.op.op2->expr_type != EXPR_CONSTANT |
| || start->value.op.op1->ref) |
| return false; |
| if (!stack_top || !stack_top->iter |
| || stack_top->iter->var->symtree |
| != start->value.op.op1->symtree) |
| return false; |
| iters[i] = stack_top->iter; |
| stack_top = stack_top->prev; |
| break; |
| default: |
| return false; |
| } |
| future_rank++; |
| break; |
| default: |
| return false; |
| } |
| } |
| |
| /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */ |
| for (int i = 1; i < ref->u.ar.dimen; i++) |
| { |
| if (iters[i]) |
| { |
| gfc_expr *var = iters[i]->var; |
| for (int j = i - 1; j < i; j++) |
| { |
| if (iters[j] |
| && (var_in_expr (var, iters[j]->start) |
| || var_in_expr (var, iters[j]->end) |
| || var_in_expr (var, iters[j]->step))) |
| return false; |
| } |
| } |
| } |
| |
| /* Create new expr. */ |
| new_e = gfc_copy_expr (curr->expr1); |
| new_e->expr_type = EXPR_VARIABLE; |
| new_e->rank = future_rank; |
| if (curr->expr1->shape) |
| new_e->shape = gfc_get_shape (new_e->rank); |
| |
| /* Assign new starts, ends and strides if necessary. */ |
| for (i = 0; i < ref->u.ar.dimen; i++) |
| { |
| if (!iters[i]) |
| continue; |
| start = ref->u.ar.start[i]; |
| switch (start->expr_type) |
| { |
| case EXPR_CONSTANT: |
| gfc_internal_error ("bad expression"); |
| break; |
| case EXPR_VARIABLE: |
| new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; |
| new_e->ref->u.ar.type = AR_SECTION; |
| gfc_free_expr (new_e->ref->u.ar.start[i]); |
| new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start); |
| new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end); |
| new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step); |
| break; |
| case EXPR_OP: |
| new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; |
| new_e->ref->u.ar.type = AR_SECTION; |
| gfc_free_expr (new_e->ref->u.ar.start[i]); |
| expr = gfc_copy_expr (start); |
| expr->value.op.op1 = gfc_copy_expr (iters[i]->start); |
| new_e->ref->u.ar.start[i] = expr; |
| gfc_simplify_expr (new_e->ref->u.ar.start[i], 0); |
| expr = gfc_copy_expr (start); |
| expr->value.op.op1 = gfc_copy_expr (iters[i]->end); |
| new_e->ref->u.ar.end[i] = expr; |
| gfc_simplify_expr (new_e->ref->u.ar.end[i], 0); |
| switch (start->value.op.op) |
| { |
| case INTRINSIC_MINUS: |
| case INTRINSIC_PLUS: |
| new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step); |
| break; |
| case INTRINSIC_TIMES: |
| expr = gfc_copy_expr (start); |
| expr->value.op.op1 = gfc_copy_expr (iters[i]->step); |
| new_e->ref->u.ar.stride[i] = expr; |
| gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0); |
| break; |
| default: |
| gfc_internal_error ("bad op"); |
| } |
| break; |
| default: |
| gfc_internal_error ("bad expression"); |
| } |
| } |
| curr->expr1 = new_e; |
| |
| /* Insert modified statement. Check whether the statement needs to be |
| inserted at the lowest level. */ |
| if (!stack_top->iter) |
| { |
| if (prev) |
| { |
| curr->next = prev->next->next; |
| prev->next = curr; |
| } |
| else |
| { |
| curr->next = stack_top->code->block->next->next->next; |
| stack_top->code->block->next = curr; |
| } |
| } |
| else |
| stack_top->code->block->next = curr; |
| return true; |
| } |
| |
| /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it |
| tries to optimize its block. */ |
| |
| static int |
| simplify_io_impl_do (gfc_code **code, int *walk_subtrees, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_code **curr, *prev = NULL; |
| struct do_stack write, first; |
| bool b = false; |
| *walk_subtrees = 1; |
| if (!(*code)->block |
| || ((*code)->block->op != EXEC_WRITE |
| && (*code)->block->op != EXEC_READ)) |
| return 0; |
| |
| *walk_subtrees = 0; |
| write.prev = NULL; |
| write.iter = NULL; |
| write.code = *code; |
| |
| for (curr = &(*code)->block; *curr; curr = &(*curr)->next) |
| { |
| if ((*curr)->op == EXEC_DO) |
| { |
| first.prev = &write; |
| first.iter = (*curr)->ext.iterator; |
| first.code = *curr; |
| stack_top = &first; |
| traverse_io_block ((*curr)->block->next, &b, prev); |
| stack_top = NULL; |
| } |
| prev = *curr; |
| } |
| return 0; |
| } |
| |
| /* Optimize a namespace, including all contained namespaces. |
| flag_frontend_optimize and flag_fronend_loop_interchange are |
| handled separately. */ |
| |
| static void |
| optimize_namespace (gfc_namespace *ns) |
| { |
| gfc_namespace *saved_ns = gfc_current_ns; |
| current_ns = ns; |
| gfc_current_ns = ns; |
| forall_level = 0; |
| iterator_level = 0; |
| in_assoc_list = false; |
| in_omp_workshare = false; |
| in_omp_atomic = false; |
| |
| if (flag_frontend_optimize) |
| { |
| gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL); |
| gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL); |
| gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); |
| gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); |
| gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); |
| if (flag_inline_matmul_limit != 0 || flag_external_blas) |
| { |
| bool found; |
| do |
| { |
| found = false; |
| gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr, |
| (void *) &found); |
| } |
| while (found); |
| |
| gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback, |
| NULL); |
| } |
| |
| if (flag_external_blas) |
| gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback, |
| NULL); |
| |
| if (flag_inline_matmul_limit != 0) |
| gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback, |
| NULL); |
| } |
| |
| if (flag_frontend_loop_interchange) |
| gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback, |
| NULL); |
| |
| /* BLOCKs are handled in the expression walker below. */ |
| for (ns = ns->contained; ns; ns = ns->sibling) |
| { |
| if (ns->code == NULL || ns->code->op != EXEC_BLOCK) |
| optimize_namespace (ns); |
| } |
| gfc_current_ns = saved_ns; |
| } |
| |
| /* Handle dependencies for allocatable strings which potentially redefine |
| themselves in an assignment. */ |
| |
| static void |
| realloc_strings (gfc_namespace *ns) |
| { |
| current_ns = ns; |
| gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL); |
| |
| for (ns = ns->contained; ns; ns = ns->sibling) |
| { |
| if (ns->code == NULL || ns->code->op != EXEC_BLOCK) |
| realloc_strings (ns); |
| } |
| |
| } |
| |
| static void |
| optimize_reduction (gfc_namespace *ns) |
| { |
| current_ns = ns; |
| gfc_code_walker (&ns->code, gfc_dummy_code_callback, |
| callback_reduction, NULL); |
| |
| /* BLOCKs are handled in the expression walker below. */ |
| for (ns = ns->contained; ns; ns = ns->sibling) |
| { |
| if (ns->code == NULL || ns->code->op != EXEC_BLOCK) |
| optimize_reduction (ns); |
| } |
| } |
| |
| /* Replace code like |
| a = matmul(b,c) + d |
| with |
| a = matmul(b,c) ; a = a + d |
| where the array function is not elemental and not allocatable |
| and does not depend on the left-hand side. |
| */ |
| |
| static bool |
| optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) |
| { |
| gfc_expr *e; |
| |
| if (!*rhs) |
| return false; |
| |
| e = *rhs; |
| if (e->expr_type == EXPR_OP) |
| { |
| switch (e->value.op.op) |
| { |
| /* Unary operators and exponentiation: Only look at a single |
| operand. */ |
| case INTRINSIC_NOT: |
| case INTRINSIC_UPLUS: |
| case INTRINSIC_UMINUS: |
| case INTRINSIC_PARENTHESES: |
| case INTRINSIC_POWER: |
| if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op)) |
| return true; |
| break; |
| |
| case INTRINSIC_CONCAT: |
| /* Do not do string concatenations. */ |
| break; |
| |
| default: |
| /* Binary operators. */ |
| if (optimize_binop_array_assignment (c, &e->value.op.op1, true)) |
| return true; |
| |
| if (optimize_binop_array_assignment (c, &e->value.op.op2, true)) |
| return true; |
| |
| break; |
| } |
| } |
| else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0 |
| && ! (e->value.function.esym |
| && (e->value.function.esym->attr.elemental |
| || e->value.function.esym->attr.allocatable |
| || e->value.function.esym->ts.type != c->expr1->ts.type |
| || e->value.function.esym->ts.kind != c->expr1->ts.kind)) |
| && ! (e->value.function.isym |
| && (e->value.function.isym->elemental |
| || e->ts.type != c->expr1->ts.type |
| || e->ts.kind != c->expr1->ts.kind)) |
| && ! gfc_inline_intrinsic_function_p (e)) |
| { |
| |
| gfc_code *n; |
| gfc_expr *new_expr; |
| |
| /* Insert a new assignment statement after the current one. */ |
| n = XCNEW (gfc_code); |
| n->op = EXEC_ASSIGN; |
| n->loc = c->loc; |
| n->next = c->next; |
| c->next = n; |
| |
| n->expr1 = gfc_copy_expr (c->expr1); |
| n->expr2 = c->expr2; |
| new_expr = gfc_copy_expr (c->expr1); |
| c->expr2 = e; |
| *rhs = new_expr; |
| |
| return true; |
| |
| } |
| |
| /* Nothing to optimize. */ |
| return false; |
| } |
| |
| /* Remove unneeded TRIMs at the end of expressions. */ |
| |
| static bool |
| remove_trim (gfc_expr *rhs) |
| { |
| bool ret; |
| |
| ret = false; |
| if (!rhs) |
| return ret; |
| |
| /* Check for a // b // trim(c). Looping is probably not |
| necessary because the parser usually generates |
| (// (// a b ) trim(c) ) , but better safe than sorry. */ |
| |
| while (rhs->expr_type == EXPR_OP |
| && rhs->value.op.op == INTRINSIC_CONCAT) |
| rhs = rhs->value.op.op2; |
| |
| while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym |
| && rhs->value.function.isym->id == GFC_ISYM_TRIM) |
| { |
| strip_function_call (rhs); |
| /* Recursive call to catch silly stuff like trim ( a // trim(b)). */ |
| remove_trim (rhs); |
| ret = true; |
| } |
| |
| return ret; |
| } |
| |
| /* Optimizations for an assignment. */ |
| |
| static void |
| optimize_assignment (gfc_code * c) |
| { |
| gfc_expr *lhs, *rhs; |
| |
| lhs = c->expr1; |
| rhs = c->expr2; |
| |
| if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred) |
| { |
| /* Optimize a = trim(b) to a = b. */ |
| remove_trim (rhs); |
| |
| /* Replace a = ' ' by a = '' to optimize away a memcpy. */ |
| if (is_empty_string (rhs)) |
| rhs->value.character.length = 0; |
| } |
| |
| if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0) |
| optimize_binop_array_assignment (c, &rhs, false); |
| } |
| |
| |
| /* Remove an unneeded function call, modifying the expression. |
| This replaces the function call with the value of its |
| first argument. The rest of the argument list is freed. */ |
| |
| static void |
| strip_function_call (gfc_expr *e) |
| { |
| gfc_expr *e1; |
| gfc_actual_arglist *a; |
| |
| a = e->value.function.actual; |
| |
| /* We should have at least one argument. */ |
| gcc_assert (a->expr != NULL); |
| |
| e1 = a->expr; |
| |
| /* Free the remaining arglist, if any. */ |
| if (a->next) |
| gfc_free_actual_arglist (a->next); |
| |
| /* Graft the argument expression onto the original function. */ |
| *e = *e1; |
| free (e1); |
| |
| } |
| |
| /* Optimization of lexical comparison functions. */ |
| |
| static bool |
| optimize_lexical_comparison (gfc_expr *e) |
| { |
| if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL) |
| return false; |
| |
| switch (e->value.function.isym->id) |
| { |
| case GFC_ISYM_LLE: |
| return optimize_comparison (e, INTRINSIC_LE); |
| |
| case GFC_ISYM_LGE: |
| return optimize_comparison (e, INTRINSIC_GE); |
| |
| case GFC_ISYM_LGT: |
| return optimize_comparison (e, INTRINSIC_GT); |
| |
| case GFC_ISYM_LLT: |
| return optimize_comparison (e, INTRINSIC_LT); |
| |
| default: |
| break; |
| } |
| return false; |
| } |
| |
| /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not |
| do CHARACTER because of possible pessimization involving character |
| lengths. */ |
| |
| static bool |
| combine_array_constructor (gfc_expr *e) |
| { |
| |
| gfc_expr *op1, *op2; |
| gfc_expr *scalar; |
| gfc_expr *new_expr; |
| gfc_constructor *c, *new_c; |
| gfc_constructor_base oldbase, newbase; |
| bool scalar_first; |
| int n_elem; |
| bool all_const; |
| |
| /* Array constructors have rank one. */ |
| if (e->rank != 1) |
| return false; |
| |
| /* Don't try to combine association lists, this makes no sense |
| and leads to an ICE. */ |
| if (in_assoc_list) |
| return false; |
| |
| /* With FORALL, the BLOCKS created by create_var will cause an ICE. */ |
| if (forall_level > 0) |
| return false; |
| |
| /* Inside an iterator, things can get hairy; we are likely to create |
| an invalid temporary variable. */ |
| if (iterator_level > 0) |
| return false; |
| |
| /* WHERE also doesn't work. */ |
| if (in_where > 0) |
| return false; |
| |
| op1 = e->value.op.op1; |
| op2 = e->value.op.op2; |
| |
| if (!op1 || !op2) |
| return false; |
| |
| if (op1->expr_type == EXPR_ARRAY && op2->rank == 0) |
| scalar_first = false; |
| else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0) |
| { |
| scalar_first = true; |
| op1 = e->value.op.op2; |
| op2 = e->value.op.op1; |
| } |
| else |
| return false; |
| |
| if (op2->ts.type == BT_CHARACTER) |
| return false; |
| |
| /* This might be an expanded constructor with very many constant values. If |
| we perform the operation here, we might end up with a long compile time |
| and actually longer execution time, so a length bound is in order here. |
| If the constructor constains something which is not a constant, it did |
| not come from an expansion, so leave it alone. */ |
| |
| #define CONSTR_LEN_MAX 4 |
| |
| oldbase = op1->value.constructor; |
| |
| n_elem = 0; |
| all_const = true; |
| for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c)) |
| { |
| if (c->expr->expr_type != EXPR_CONSTANT) |
| { |
| all_const = false; |
| break; |
| } |
| n_elem += 1; |
| } |
| |
| if (all_const && n_elem > CONSTR_LEN_MAX) |
| return false; |
| |
| #undef CONSTR_LEN_MAX |
| |
| newbase = NULL; |
| e->expr_type = EXPR_ARRAY; |
| |
| scalar = create_var (gfc_copy_expr (op2), "constr"); |
| |
| for (c = gfc_constructor_first (oldbase); c; |
| c = gfc_constructor_next (c)) |
| { |
| new_expr = gfc_get_expr (); |
| new_expr->ts = e->ts; |
| new_expr->expr_type = EXPR_OP; |
| new_expr->rank = c->expr->rank; |
| new_expr->where = c->expr->where; |
| new_expr->value.op.op = e->value.op.op; |
| |
| if (scalar_first) |
| { |
| new_expr->value.op.op1 = gfc_copy_expr (scalar); |
| new_expr->value.op.op2 = gfc_copy_expr (c->expr); |
| } |
| else |
| { |
| new_expr->value.op.op1 = gfc_copy_expr (c->expr); |
| new_expr->value.op.op2 = gfc_copy_expr (scalar); |
| } |
| |
| new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where)); |
| new_c->iterator = c->iterator; |
| c->iterator = NULL; |
| } |
| |
| gfc_free_expr (op1); |
| gfc_free_expr (op2); |
| gfc_free_expr (scalar); |
| |
| e->value.constructor = newbase; |
| return true; |
| } |
| |
| /* Recursive optimization of operators. */ |
| |
| static bool |
| optimize_op (gfc_expr *e) |
| { |
| bool changed; |
| |
| gfc_intrinsic_op op = e->value.op.op; |
| |
| changed = false; |
| |
| /* Only use new-style comparisons. */ |
| switch(op) |
| { |
| case INTRINSIC_EQ_OS: |
| op = INTRINSIC_EQ; |
| break; |
| |
| case INTRINSIC_GE_OS: |
| op = INTRINSIC_GE; |
| break; |
| |
| case INTRINSIC_LE_OS: |
| op = INTRINSIC_LE; |
| break; |
| |
| case INTRINSIC_NE_OS: |
| op = INTRINSIC_NE; |
| break; |
| |
| case INTRINSIC_GT_OS: |
| op = INTRINSIC_GT; |
| break; |
| |
| case INTRINSIC_LT_OS: |
| op = INTRINSIC_LT; |
| break; |
| |
| default: |
| break; |
| } |
| |
| switch (op) |
| { |
| case INTRINSIC_EQ: |
| case INTRINSIC_GE: |
| case INTRINSIC_LE: |
| case INTRINSIC_NE: |
| case INTRINSIC_GT: |
| case INTRINSIC_LT: |
| changed = optimize_comparison (e, op); |
| |
| gcc_fallthrough (); |
| /* Look at array constructors. */ |
| case INTRINSIC_PLUS: |
| case INTRINSIC_MINUS: |
| case INTRINSIC_TIMES: |
| case INTRINSIC_DIVIDE: |
| return combine_array_constructor (e) || changed; |
| |
| default: |
| break; |
| } |
| |
| return false; |
| } |
| |
| |
| /* Return true if a constant string contains only blanks. */ |
| |
| static bool |
| is_empty_string (gfc_expr *e) |
| { |
| int i; |
| |
| if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) |
| return false; |
| |
| for (i=0; i < e->value.character.length; i++) |
| { |
| if (e->value.character.string[i] != ' ') |
| return false; |
| } |
| |
| return true; |
| } |
| |
| |
| /* Insert a call to the intrinsic len_trim. Use a different name for |
| the symbol tree so we don't run into trouble when the user has |
| renamed len_trim for some reason. */ |
| |
| static gfc_expr* |
| get_len_trim_call (gfc_expr *str, int kind) |
| { |
| gfc_expr *fcn; |
| gfc_actual_arglist *actual_arglist, *next; |
| |
| fcn = gfc_get_expr (); |
| fcn->expr_type = EXPR_FUNCTION; |
| fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); |
| actual_arglist = gfc_get_actual_arglist (); |
| actual_arglist->expr = str; |
| next = gfc_get_actual_arglist (); |
| next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind); |
| actual_arglist->next = next; |
| |
| fcn->value.function.actual = actual_arglist; |
| fcn->where = str->where; |
| fcn->ts.type = BT_INTEGER; |
| fcn->ts.kind = gfc_charlen_int_kind; |
| |
| gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false); |
| fcn->symtree->n.sym->ts = fcn->ts; |
| fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; |
| fcn->symtree->n.sym->attr.function = 1; |
| fcn->symtree->n.sym->attr.elemental = 1; |
| fcn->symtree->n.sym->attr.referenced = 1; |
| fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; |
| gfc_commit_symbol (fcn->symtree->n.sym); |
| |
| return fcn; |
| } |
| |
| |
| /* Optimize expressions for equality. */ |
| |
| static bool |
| optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) |
| { |
| gfc_expr *op1, *op2; |
| bool change; |
| int eq; |
| bool result; |
| gfc_actual_arglist *firstarg, *secondarg; |
| |
| if (e->expr_type == EXPR_OP) |
| { |
| firstarg = NULL; |
| secondarg = NULL; |
| op1 = e->value.op.op1; |
| op2 = e->value.op.op2; |
| } |
| else if (e->expr_type == EXPR_FUNCTION) |
| { |
| /* One of the lexical comparison functions. */ |
| firstarg = e->value.function.actual; |
| secondarg = firstarg->next; |
| op1 = firstarg->expr; |
| op2 = secondarg->expr; |
| } |
| else |
| gcc_unreachable (); |
| |
| /* Strip off unneeded TRIM calls from string comparisons. */ |
| |
| change = remove_trim (op1); |
| |
| if (remove_trim (op2)) |
| change = true; |
| |
| /* An expression of type EXPR_CONSTANT is only valid for scalars. */ |
| /* TODO: A scalar constant may be acceptable in some cases (the scalarizer |
| handles them well). However, there are also cases that need a non-scalar |
| argument. For example the any intrinsic. See PR 45380. */ |
| if (e->rank > 0) |
| return change; |
| |
| /* Replace a == '' with len_trim(a) == 0 and a /= '' with |
| len_trim(a) != 0 */ |
| if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER |
| && (op == INTRINSIC_EQ || op == INTRINSIC_NE)) |
| { |
| bool empty_op1, empty_op2; |
| empty_op1 = is_empty_string (op1); |
| empty_op2 = is_empty_string (op2); |
| |
| if (empty_op1 || empty_op2) |
| { |
| gfc_expr *fcn; |
| gfc_expr *zero; |
| gfc_expr *str; |
| |
| /* This can only happen when an error for comparing |
| characters of different kinds has already been issued. */ |
| if (empty_op1 && empty_op2) |
| return false; |
| |
| zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0); |
| str = empty_op1 ? op2 : op1; |
| |
| fcn = get_len_trim_call (str, gfc_charlen_int_kind); |
| |
| |
| if (empty_op1) |
| gfc_free_expr (op1); |
| else |
| gfc_free_expr (op2); |
| |
| op1 = fcn; |
| op2 = zero; |
| e->value.op.op1 = fcn; |
| e->value.op.op2 = zero; |
| } |
| } |
| |
| |
| /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */ |
| |
| if (flag_finite_math_only |
| || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL |
| && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX)) |
| { |
| eq = gfc_dep_compare_expr (op1, op2); |
| if (eq <= -2) |
| { |
| /* Replace A // B < A // C with B < C, and A // B < C // B |
| with A < C. */ |
| if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER |
| && op1->expr_type == EXPR_OP |
| && op1->value.op.op == INTRINSIC_CONCAT |
| && op2->expr_type == EXPR_OP |
| && op2->value.op.op == INTRINSIC_CONCAT) |
| { |
| gfc_expr *op1_left = op1->value.op.op1; |
| gfc_expr *op2_left = op2->value.op.op1; |
| gfc_expr *op1_right = op1->value.op.op2; |
| gfc_expr *op2_right = op2->value.op.op2; |
| |
| if (gfc_dep_compare_expr (op1_left, op2_left) == 0) |
| { |
| /* Watch out for 'A ' // x vs. 'A' // x. */ |
| |
| if (op1_left->expr_type == EXPR_CONSTANT |
| && op2_left->expr_type == EXPR_CONSTANT |
| && op1_left->value.character.length |
| != op2_left->value.character.length) |
| return change; |
| else |
| { |
| free (op1_left); |
| free (op2_left); |
| if (firstarg) |
| { |
| firstarg->expr = op1_right; |
| secondarg->expr = op2_right; |
| } |
| else |
| { |
| e->value.op.op1 = op1_right; |
| e->value.op.op2 = op2_right; |
| } |
| optimize_comparison (e, op); |
| return true; |
| } |
| } |
| if (gfc_dep_compare_expr (op1_right, op2_right) == 0) |
| { |
| free (op1_right); |
| free (op2_right); |
| if (firstarg) |
| { |
| firstarg->expr = op1_left; |
| secondarg->expr = op2_left; |
| } |
| else |
| { |
| e->value.op.op1 = op1_left; |
| e->value.op.op2 = op2_left; |
| } |
| |
| optimize_comparison (e, op); |
| return true; |
| } |
| } |
| } |
| else |
| { |
| /* eq can only be -1, 0 or 1 at this point. */ |
| switch (op) |
| { |
| case INTRINSIC_EQ: |
| result = eq == 0; |
| break; |
| |
| case INTRINSIC_GE: |
| result = eq >= 0; |
| break; |
| |
| case INTRINSIC_LE: |
| result = eq <= 0; |
| break; |
| |
| case INTRINSIC_NE: |
| result = eq != 0; |
| break; |
| |
| case INTRINSIC_GT: |
| result = eq > 0; |
| break; |
| |
| case INTRINSIC_LT: |
| result = eq < 0; |
| break; |
| |
| default: |
| gfc_internal_error ("illegal OP in optimize_comparison"); |
| break; |
| } |
| |
| /* Replace the expression by a constant expression. The typespec |
| and where remains the way it is. */ |
| free (op1); |
| free (op2); |
| e->expr_type = EXPR_CONSTANT; |
| e->value.logical = result; |
| return true; |
| } |
| } |
| |
| return change; |
| } |
| |
| /* Optimize a trim function by replacing it with an equivalent substring |
| involving a call to len_trim. This only works for expressions where |
| variables are trimmed. Return true if anything was modified. */ |
| |
| static bool |
| optimize_trim (gfc_expr *e) |
| { |
| gfc_expr *a; |
| gfc_ref *ref; |
| gfc_expr *fcn; |
| gfc_ref **rr = NULL; |
| |
| /* Don't do this optimization within an argument list, because |
| otherwise aliasing issues may occur. */ |
| |
| if (count_arglist != 1) |
| return false; |
| |
| if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION |
| || e->value.function.isym == NULL |
| || e->value.function.isym->id != GFC_ISYM_TRIM) |
| return false; |
| |
| a = e->value.function.actual->expr; |
| |
| if (a->expr_type != EXPR_VARIABLE) |
| return false; |
| |
| /* This would pessimize the idiom a = trim(a) for reallocatable strings. */ |
| |
| if (a->symtree->n.sym->attr.allocatable) |
| return false; |
| |
| /* Follow all references to find the correct place to put the newly |
| created reference. FIXME: Also handle substring references and |
| array references. Array references cause strange regressions at |
| the moment. */ |
| |
| if (a->ref) |
| { |
| for (rr = &(a->ref); *rr; rr = &((*rr)->next)) |
| { |
| if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY) |
| return false; |
| } |
| } |
| |
| strip_function_call (e); |
| |
| if (e->ref == NULL) |
| rr = &(e->ref); |
| |
| /* Create the reference. */ |
| |
| ref = gfc_get_ref (); |
| ref->type = REF_SUBSTRING; |
| |
| /* Set the start of the reference. */ |
| |
| ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); |
| |
| /* Build the function call to len_trim(x, gfc_default_integer_kind). */ |
| |
| fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind); |
| |
| /* Set the end of the reference to the call to len_trim. */ |
| |
| ref->u.ss.end = fcn; |
| gcc_assert (rr != NULL && *rr == NULL); |
| *rr = ref; |
| return true; |
| } |
| |
| /* Optimize minloc(b), where b is rank 1 array, into |
| (/ minloc(b, dim=1) /), and similarly for maxloc, |
| as the latter forms are expanded inline. */ |
| |
| static void |
| optimize_minmaxloc (gfc_expr **e) |
| { |
| gfc_expr *fn = *e; |
| gfc_actual_arglist *a; |
| char *name, *p; |
| |
| if (fn->rank != 1 |
| || fn->value.function.actual == NULL |
| || fn->value.function.actual->expr == NULL |
| || fn->value.function.actual->expr->rank != 1) |
| return; |
| |
| *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where); |
| (*e)->shape = fn->shape; |
| fn->rank = 0; |
| fn->shape = NULL; |
| gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where); |
| |
| name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1); |
| strcpy (name, fn->value.function.name); |
| p = strstr (name, "loc0"); |
| p[3] = '1'; |
| fn->value.function.name = gfc_get_string ("%s", name); |
| if (fn->value.function.actual->next) |
| { |
| a = fn->value.function.actual->next; |
| gcc_assert (a->expr == NULL); |
| } |
| else |
| { |
| a = gfc_get_actual_arglist (); |
| fn->value.function.actual->next = a; |
| } |
| a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, |
| &fn->where); |
| mpz_set_ui (a->expr->value.integer, 1); |
| } |
| |
| /* Data package to hand down for DO loop checks in a contained |
| procedure. */ |
| typedef struct contained_info |
| { |
| gfc_symbol *do_var; |
| gfc_symbol *procedure; |
| locus where_do; |
| } contained_info; |
| |
| static enum gfc_exec_op last_io_op; |
| |
| /* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a |
| contained function call. */ |
| |
| static int |
| doloop_contained_function_call (gfc_expr **e, |
| int *walk_subtrees ATTRIBUTE_UNUSED, void *data) |
| { |
| gfc_expr *expr = *e; |
| gfc_formal_arglist *f; |
| gfc_actual_arglist *a; |
| gfc_symbol *sym, *do_var; |
| contained_info *info; |
| |
| if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym |
| || expr->value.function.esym == NULL) |
| return 0; |
| |
| sym = expr->value.function.esym; |
| f = gfc_sym_get_dummy_args (sym); |
| if (f == NULL) |
| return 0; |
| |
| info = (contained_info *) data; |
| do_var = info->do_var; |
| a = expr->value.function.actual; |
| |
| while (a && f) |
| { |
| if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) |
| { |
| if (f->sym->attr.intent == INTENT_OUT) |
| { |
| gfc_error_now ("Index variable %qs set to undefined as " |
| "INTENT(OUT) argument at %L in procedure %qs " |
| "called from within DO loop at %L", do_var->name, |
| &a->expr->where, info->procedure->name, |
| &info->where_do); |
| return 1; |
| } |
| else if (f->sym->attr.intent == INTENT_INOUT) |
| { |
| gfc_error_now ("Index variable %qs not definable as " |
| "INTENT(INOUT) argument at %L in procedure %qs " |
| "called from within DO loop at %L", do_var->name, |
| &a->expr->where, info->procedure->name, |
| &info->where_do); |
| return 1; |
| } |
| } |
| a = a->next; |
| f = f->next; |
| } |
| return 0; |
| } |
| |
| /* Callback function that goes through the code in a contained |
| procedure to make sure it does not change a variable in a DO |
| loop. */ |
| |
| static int |
| doloop_contained_procedure_code (gfc_code **c, |
| int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data) |
| { |
| gfc_code *co = *c; |
| contained_info *info = (contained_info *) data; |
| gfc_symbol *do_var = info->do_var; |
| const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs " |
| "called from within DO loop at %L"); |
| static enum gfc_exec_op saved_io_op; |
| |
| switch (co->op) |
| { |
| case EXEC_ASSIGN: |
| if (co->expr1->symtree->n.sym == do_var) |
| gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name, |
| &info->where_do); |
| break; |
| |
| case EXEC_DO: |
| if (co->ext.iterator && co->ext.iterator->var |
| && co->ext.iterator->var->symtree->n.sym == do_var) |
| gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name, |
| &info->where_do); |
| break; |
| |
| case EXEC_READ: |
| case EXEC_WRITE: |
| case EXEC_INQUIRE: |
| case EXEC_IOLENGTH: |
| saved_io_op = last_io_op; |
| last_io_op = co->op; |
| break; |
| |
| case EXEC_OPEN: |
| if (co->ext.open->iostat |
| && co->ext.open->iostat->symtree->n.sym == do_var) |
| gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where, |
| info->procedure->name, &info->where_do); |
| break; |
| |
| case EXEC_CLOSE: |
| if (co->ext.close->iostat |
| && co->ext.close->iostat->symtree->n.sym == do_var) |
| gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where, |
| info->procedure->name, &info->where_do); |
| break; |
| |
| case EXEC_TRANSFER: |
| switch (last_io_op) |
| { |
| |
| case EXEC_INQUIRE: |
| #define CHECK_INQ(a) do { if (co->ext.inquire->a && \ |
| co->ext.inquire->a->symtree->n.sym == do_var) \ |
| gfc_error_now (errmsg, do_var->name, \ |
| &co->ext.inquire->a->where, \ |
| info->procedure->name, \ |
| &info->where_do); \ |
| } while (0) |
| |
| CHECK_INQ(iostat); |
| CHECK_INQ(number); |
| CHECK_INQ(position); |
| CHECK_INQ(recl); |
| CHECK_INQ(position); |
| CHECK_INQ(iolength); |
| CHECK_INQ(strm_pos); |
| break; |
| #undef CHECK_INQ |
| |
| case EXEC_READ: |
| if (co->expr1 && co->expr1->symtree->n.sym == do_var) |
| gfc_error_now (errmsg, do_var->name, &co->expr1->where, |
| info->procedure->name, &info->where_do); |
| |
| /* Fallthrough. */ |
| |
| case EXEC_WRITE: |
| if (co->ext.dt->iostat |
| && co->ext.dt->iostat->symtree->n.sym == do_var) |
| gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where, |
| info->procedure->name, &info->where_do); |
| break; |
| |
| case EXEC_IOLENGTH: |
| if (co->expr1 && co->expr1->symtree->n.sym == do_var) |
| gfc_error_now (errmsg, do_var->name, &co->expr1->where, |
| info->procedure->name, &info->where_do); |
| break; |
| |
| default: |
| gcc_unreachable (); |
| } |
| break; |
| |
| case EXEC_DT_END: |
| last_io_op = saved_io_op; |
| break; |
| |
| case EXEC_CALL: |
| gfc_formal_arglist *f; |
| gfc_actual_arglist *a; |
| |
| f = gfc_sym_get_dummy_args (co->resolved_sym); |
| if (f == NULL) |
| break; |
| a = co->ext.actual; |
| /* Slightly different error message here. If there is an error, |
| return 1 to avoid an infinite loop. */ |
| while (a && f) |
| { |
| if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) |
| { |
| if (f->sym->attr.intent == INTENT_OUT) |
| { |
| gfc_error_now ("Index variable %qs set to undefined as " |
| "INTENT(OUT) argument at %L in subroutine %qs " |
| "called from within DO loop at %L", |
| do_var->name, &a->expr->where, |
| info->procedure->name, &info->where_do); |
| return 1; |
| } |
| else if (f->sym->attr.intent == INTENT_INOUT) |
| { |
| gfc_error_now ("Index variable %qs not definable as " |
| "INTENT(INOUT) argument at %L in subroutine %qs " |
| "called from within DO loop at %L", do_var->name, |
| &a->expr->where, info->procedure->name, |
| &info->where_do); |
| return 1; |
| } |
| } |
| a = a->next; |
| f = f->next; |
| } |
| break; |
| default: |
| break; |
| } |
| return 0; |
| } |
| |
| /* Callback function for code checking that we do not pass a DO variable to an |
| INTENT(OUT) or INTENT(INOUT) dummy variable. */ |
| |
| static int |
| doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_code *co; |
| int i; |
| gfc_formal_arglist *f; |
| gfc_actual_arglist *a; |
| gfc_code *cl; |
| do_t loop, *lp; |
| bool seen_goto; |
| |
| co = *c; |
| |
| /* If the doloop_list grew, we have to truncate it here. */ |
| |
| if ((unsigned) doloop_level < doloop_list.length()) |
| doloop_list.truncate (doloop_level); |
| |
| seen_goto = false; |
| switch (co->op) |
| { |
| case EXEC_DO: |
| |
| if (co->ext.iterator && co->ext.iterator->var) |
| loop.c = co; |
| else |
| loop.c = NULL; |
| |
| loop.branch_level = if_level + select_level; |
| loop.seen_goto = false; |
| doloop_list.safe_push (loop); |
| break; |
| |
| /* If anything could transfer control away from a suspicious |
| subscript, make sure to set seen_goto in the current DO loop |
| (if any). */ |
| case EXEC_GOTO: |
| case EXEC_EXIT: |
| case EXEC_STOP: |
| case EXEC_ERROR_STOP: |
| case EXEC_CYCLE: |
| seen_goto = true; |
| break; |
| |
| case EXEC_OPEN: |
| if (co->ext.open->err) |
| seen_goto = true; |
| break; |
| |
| case EXEC_CLOSE: |
| if (co->ext.close->err) |
| seen_goto = true; |
| break; |
| |
| case EXEC_BACKSPACE: |
| case EXEC_ENDFILE: |
| case EXEC_REWIND: |
| case EXEC_FLUSH: |
| |
| if (co->ext.filepos->err) |
| seen_goto = true; |
| break; |
| |
| case EXEC_INQUIRE: |
| if (co->ext.filepos->err) |
| seen_goto = true; |
| break; |
| |
| case EXEC_READ: |
| case EXEC_WRITE: |
| if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor) |
| seen_goto = true; |
| break; |
| |
| case EXEC_WAIT: |
| if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor) |
| loop.seen_goto = true; |
| break; |
| |
| case EXEC_CALL: |
| if (co->resolved_sym == NULL) |
| break; |
| |
| /* Test if somebody stealthily changes the DO variable from |
| under us by changing it in a host-associated procedure. */ |
| if (co->resolved_sym->attr.contained) |
| { |
| FOR_EACH_VEC_ELT (doloop_list, i, lp) |
| { |
| gfc_symbol *sym = co->resolved_sym; |
| contained_info info; |
| gfc_namespace *ns; |
| |
| cl = lp->c; |
| info.do_var = cl->ext.iterator->var->symtree->n.sym; |
| info.procedure = co->resolved_sym; /* sym? */ |
| info.where_do = co->loc; |
| /* Look contained procedures under the namespace of the |
| variable. */ |
| for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) |
| if (ns->proc_name && ns->proc_name == sym) |
| gfc_code_walker (&ns->code, doloop_contained_procedure_code, |
| doloop_contained_function_call, &info); |
| } |
| } |
| |
| f = gfc_sym_get_dummy_args (co->resolved_sym); |
| |
| /* Withot a formal arglist, there is only unknown INTENT, |
| which we don't check for. */ |
| if (f == NULL) |
| break; |
| |
| a = co->ext.actual; |
| |
| while (a && f) |
| { |
| FOR_EACH_VEC_ELT (doloop_list, i, lp) |
| { |
| gfc_symbol *do_sym; |
| cl = lp->c; |
| |
| if (cl == NULL) |
| break; |
| |
| do_sym = cl->ext.iterator->var->symtree->n.sym; |
| |
| if (a->expr && a->expr->symtree |
| && a->expr->symtree->n.sym == do_sym) |
| { |
| if (f->sym->attr.intent == INTENT_OUT) |
| gfc_error_now ("Variable %qs at %L set to undefined " |
| "value inside loop beginning at %L as " |
| "INTENT(OUT) argument to subroutine %qs", |
| do_sym->name, &a->expr->where, |
| &(doloop_list[i].c->loc), |
| co->symtree->n.sym->name); |
| else if (f->sym->attr.intent == INTENT_INOUT) |
| gfc_error_now ("Variable %qs at %L not definable inside " |
| "loop beginning at %L as INTENT(INOUT) " |
| "argument to subroutine %qs", |
| do_sym->name, &a->expr->where, |
| &(doloop_list[i].c->loc), |
| co->symtree->n.sym->name); |
| } |
| } |
| a = a->next; |
| f = f->next; |
| } |
| |
| break; |
| |
| default: |
| break; |
| } |
| if (seen_goto && doloop_level > 0) |
| doloop_list[doloop_level-1].seen_goto = true; |
| |
| return 0; |
| } |
| |
| /* Callback function to warn about different things within DO loops. */ |
| |
| static int |
| do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| do_t *last; |
| |
| if (doloop_list.length () == 0) |
| return 0; |
| |
| if ((*e)->expr_type == EXPR_FUNCTION) |
| do_intent (e); |
| |
| last = &doloop_list.last(); |
| if (last->seen_goto && !warn_do_subscript) |
| return 0; |
| |
| if ((*e)->expr_type == EXPR_VARIABLE) |
| do_subscript (e); |
| |
| return 0; |
| } |
| |
| typedef struct |
| { |
| gfc_symbol *sym; |
| mpz_t val; |
| } insert_index_t; |
| |
| /* Callback function - if the expression is the variable in data->sym, |
| replace it with a constant from data->val. */ |
| |
| static int |
| callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data) |
| { |
| insert_index_t *d; |
| gfc_expr *ex, *n; |
| |
| ex = (*e); |
| if (ex->expr_type != EXPR_VARIABLE) |
| return 0; |
| |
| d = (insert_index_t *) data; |
| if (ex->symtree->n.sym != d->sym) |
| return 0; |
| |
| n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where); |
| mpz_set (n->value.integer, d->val); |
| |
| gfc_free_expr (ex); |
| *e = n; |
| return 0; |
| } |
| |
| /* In the expression e, replace occurrences of the variable sym with |
| val. If this results in a constant expression, return true and |
| return the value in ret. Return false if the expression already |
| is a constant. Caller has to clear ret in that case. */ |
| |
| static bool |
| insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret) |
| { |
| gfc_expr *n; |
| insert_index_t data; |
| bool rc; |
| |
| if (e->expr_type == EXPR_CONSTANT) |
| return false; |
| |
| n = gfc_copy_expr (e); |
| data.sym = sym; |
| mpz_init_set (data.val, val); |
| gfc_expr_walker (&n, callback_insert_index, (void *) &data); |
| |
| /* Suppress errors here - we could get errors here such as an |
| out of bounds access for arrays, see PR 90563. */ |
| gfc_push_suppress_errors (); |
| gfc_simplify_expr (n, 0); |
| gfc_pop_suppress_errors (); |
| |
| if (n->expr_type == EXPR_CONSTANT) |
| { |
| rc = true; |
| mpz_init_set (ret, n->value.integer); |
| } |
| else |
| rc = false; |
| |
| mpz_clear (data.val); |
| gfc_free_expr (n); |
| return rc; |
| |
| } |
| |
| /* Check array subscripts for possible out-of-bounds accesses in DO |
| loops with constant bounds. */ |
| |
| static int |
| do_subscript (gfc_expr **e) |
| { |
| gfc_expr *v; |
| gfc_array_ref *ar; |
| gfc_ref *ref; |
| int i,j; |
| gfc_code *dl; |
| do_t *lp; |
| |
| v = *e; |
| /* Constants are already checked. */ |
| if (v->expr_type == EXPR_CONSTANT) |
| return 0; |
| |
| /* Wrong warnings will be generated in an associate list. */ |
| if (in_assoc_list) |
| return 0; |
| |
| /* We already warned about this. */ |
| if (v->do_not_warn) |
| return 0; |
| |
| v->do_not_warn = 1; |
| |
| for (ref = v->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT) |
| { |
| ar = & ref->u.ar; |
| FOR_EACH_VEC_ELT (doloop_list, j, lp) |
| { |
| gfc_symbol *do_sym; |
| mpz_t do_start, do_step, do_end; |
| bool have_do_start, have_do_end; |
| bool error_not_proven; |
| int warn; |
| int sgn; |
| |
| dl = lp->c; |
| if (dl == NULL) |
| break; |
| |
| /* If we are within a branch, or a goto or equivalent |
| was seen in the DO loop before, then we cannot prove that |
| this expression is actually evaluated. Don't do anything |
| unless we want to see it all. */ |
| error_not_proven = lp->seen_goto |
| || lp->branch_level < if_level + select_level; |
| |
| if (error_not_proven && !warn_do_subscript) |
| break; |
| |
| if (error_not_proven) |
| warn = OPT_Wdo_subscript; |
| else |
| warn = 0; |
| |
| do_sym = dl->ext.iterator->var->symtree->n.sym; |
| if (do_sym->ts.type != BT_INTEGER) |
| continue; |
| |
| /* If we do not know about the stepsize, the loop may be zero trip. |
| Do not warn in this case. */ |
| |
| if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT) |
| { |
| sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0); |
| /* This can happen, but then the error has been |
| reported previously. */ |
| if (sgn == 0) |
| continue; |
| |
| mpz_init_set (do_step, dl->ext.iterator->step->value.integer); |
| } |
| |
| else |
| continue; |
| |
| if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT) |
| { |
| have_do_start = true; |
| mpz_init_set (do_start, dl->ext.iterator->start->value.integer); |
| } |
| else |
| have_do_start = false; |
| |
| if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT) |
| { |
| have_do_end = true; |
| mpz_init_set (do_end, dl->ext.iterator->end->value.integer); |
| } |
| else |
| have_do_end = false; |
| |
| if (!have_do_start && !have_do_end) |
| return 0; |
| |
| /* No warning inside a zero-trip loop. */ |
| if (have_do_start && have_do_end) |
| { |
| int cmp; |
| |
| cmp = mpz_cmp (do_end, do_start); |
| if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)) |
| break; |
| } |
| |
| /* May have to correct the end value if the step does not equal |
| one. */ |
| if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0) |
| { |
| mpz_t diff, rem; |
| |
| mpz_init (diff); |
| mpz_init (rem); |
| mpz_sub (diff, do_end, do_start); |
| mpz_tdiv_r (rem, diff, do_step); |
| mpz_sub (do_end, do_end, rem); |
| mpz_clear (diff); |
| mpz_clear (rem); |
| } |
| |
| for (i = 0; i< ar->dimen; i++) |
| { |
| mpz_t val; |
| if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start |
| && insert_index (ar->start[i], do_sym, do_start, val)) |
| { |
| if (ar->as->lower[i] |
| && ar->as->lower[i]->expr_type == EXPR_CONSTANT |
| && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0) |
| gfc_warning (warn, "Array reference at %L out of bounds " |
| "(%ld < %ld) in loop beginning at %L", |
| &ar->start[i]->where, mpz_get_si (val), |
| mpz_get_si (ar->as->lower[i]->value.integer), |
| &doloop_list[j].c->loc); |
| |
| if (ar->as->upper[i] |
| && ar->as->upper[i]->expr_type == EXPR_CONSTANT |
| && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0) |
| gfc_warning (warn, "Array reference at %L out of bounds " |
| "(%ld > %ld) in loop beginning at %L", |
| &ar->start[i]->where, mpz_get_si (val), |
| mpz_get_si (ar->as->upper[i]->value.integer), |
| &doloop_list[j].c->loc); |
| |
| mpz_clear (val); |
| } |
| |
| if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end |
| && insert_index (ar->start[i], do_sym, do_end, val)) |
| { |
| if (ar->as->lower[i] |
| && ar->as->lower[i]->expr_type == EXPR_CONSTANT |
| && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0) |
| gfc_warning (warn, "Array reference at %L out of bounds " |
| "(%ld < %ld) in loop beginning at %L", |
| &ar->start[i]->where, mpz_get_si (val), |
| mpz_get_si (ar->as->lower[i]->value.integer), |
| &doloop_list[j].c->loc); |
| |
| if (ar->as->upper[i] |
| && ar->as->upper[i]->expr_type == EXPR_CONSTANT |
| && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0) |
| gfc_warning (warn, "Array reference at %L out of bounds " |
| "(%ld > %ld) in loop beginning at %L", |
| &ar->start[i]->where, mpz_get_si (val), |
| mpz_get_si (ar->as->upper[i]->value.integer), |
| &doloop_list[j].c->loc); |
| |
| mpz_clear (val); |
| } |
| } |
| } |
| } |
| } |
| return 0; |
| } |
| /* Function for functions checking that we do not pass a DO variable |
| to an INTENT(OUT) or INTENT(INOUT) dummy variable. */ |
| |
| static int |
| do_intent (gfc_expr **e) |
| { |
| gfc_formal_arglist *f; |
| gfc_actual_arglist *a; |
| gfc_expr *expr; |
| gfc_code *dl; |
| do_t *lp; |
| int i; |
| gfc_symbol *sym; |
| |
| expr = *e; |
| if (expr->expr_type != EXPR_FUNCTION) |
| return 0; |
| |
| /* Intrinsic functions don't modify their arguments. */ |
| |
| if (expr->value.function.isym) |
| return 0; |
| |
| sym = expr->value.function.esym; |
| if (sym == NULL) |
| return 0; |
| |
| if (sym->attr.contained) |
| { |
| FOR_EACH_VEC_ELT (doloop_list, i, lp) |
| { |
| contained_info info; |
| gfc_namespace *ns; |
| |
| dl = lp->c; |
| info.do_var = dl->ext.iterator->var->symtree->n.sym; |
| info.procedure = sym; |
| info.where_do = expr->where; |
| /* Look contained procedures under the namespace of the |
| variable. */ |
| for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) |
| if (ns->proc_name && ns->proc_name == sym) |
| gfc_code_walker (&ns->code, doloop_contained_procedure_code, |
| dummy_expr_callback, &info); |
| } |
| } |
| |
| f = gfc_sym_get_dummy_args (sym); |
| |
| /* Without a formal arglist, there is only unknown INTENT, |
| which we don't check for. */ |
| if (f == NULL) |
| return 0; |
| |
| a = expr->value.function.actual; |
| |
| while (a && f) |
| { |
| FOR_EACH_VEC_ELT (doloop_list, i, lp) |
| { |
| gfc_symbol *do_sym; |
| dl = lp->c; |
| if (dl == NULL) |
| break; |
| |
| do_sym = dl->ext.iterator->var->symtree->n.sym; |
| |
| if (a->expr && a->expr->symtree |
| && a->expr->symtree->n.sym == do_sym) |
| { |
| if (f->sym->attr.intent == INTENT_OUT) |
| gfc_error_now ("Variable %qs at %L set to undefined value " |
| "inside loop beginning at %L as INTENT(OUT) " |
| "argument to function %qs", do_sym->name, |
| &a->expr->where, &doloop_list[i].c->loc, |
| expr->symtree->n.sym->name); |
| else if (f->sym->attr.intent == INTENT_INOUT) |
| gfc_error_now ("Variable %qs at %L not definable inside loop" |
| " beginning at %L as INTENT(INOUT) argument to" |
| " function %qs", do_sym->name, |
| &a->expr->where, &doloop_list[i].c->loc, |
| expr->symtree->n.sym->name); |
| } |
| } |
| a = a->next; |
| f = f->next; |
| } |
| |
| return 0; |
| } |
| |
| static void |
| doloop_warn (gfc_namespace *ns) |
| { |
| gfc_code_walker (&ns->code, doloop_code, do_function, NULL); |
| |
| for (ns = ns->contained; ns; ns = ns->sibling) |
| { |
| if (ns->code == NULL || ns->code->op != EXEC_BLOCK) |
| doloop_warn (ns); |
| } |
| } |
| |
| /* This selction deals with inlining calls to MATMUL. */ |
| |
| /* Replace calls to matmul outside of straight assignments with a temporary |
| variable so that later inlining will work. */ |
| |
| static int |
| matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data) |
| { |
| gfc_expr *e, *n; |
| bool *found = (bool *) data; |
| |
| e = *ep; |
| |
| if (e->expr_type != EXPR_FUNCTION |
| || e->value.function.isym == NULL |
| || e->value.function.isym->id != GFC_ISYM_MATMUL) |
| return 0; |
| |
| if (forall_level > 0 || iterator_level > 0 || in_omp_workshare |
| || in_omp_atomic || in_where || in_assoc_list) |
| return 0; |
| |
| /* Check if this is already in the form c = matmul(a,b). */ |
| |
| if ((*current_code)->expr2 == e) |
| return 0; |
| |
| n = create_var (e, "matmul"); |
| |
| /* If create_var is unable to create a variable (for example if |
| -fno-realloc-lhs is in force with a variable that does not have bounds |
| known at compile-time), just return. */ |
| |
| if (n == NULL) |
| return 0; |
| |
| *ep = n; |
| *found = true; |
| return 0; |
| } |
| |
| /* Set current_code and associated variables so that matmul_to_var_expr can |
| work. */ |
| |
| static int |
| matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| if (current_code != c) |
| { |
| current_code = c; |
| inserted_block = NULL; |
| changed_statement = NULL; |
| } |
| |
| return 0; |
| } |
| |
| |
| /* Take a statement of the shape c = matmul(a,b) and create temporaries |
| for a and b if there is a dependency between the arguments and the |
| result variable or if a or b are the result of calculations that cannot |
| be handled by the inliner. */ |
| |
| static int |
| matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_expr *expr1, *expr2; |
| gfc_code *co; |
| gfc_actual_arglist *a, *b; |
| bool a_tmp, b_tmp; |
| gfc_expr *matrix_a, *matrix_b; |
| bool conjg_a, conjg_b, transpose_a, transpose_b; |
| |
| co = *c; |
| |
| if (co->op != EXEC_ASSIGN) |
| return 0; |
| |
| if (forall_level > 0 || iterator_level > 0 || in_omp_workshare |
| || in_omp_atomic || in_where) |
| return 0; |
| |
| /* This has some duplication with inline_matmul_assign. This |
| is because the creation of temporary variables could still fail, |
| and inline_matmul_assign still needs to be able to handle these |
| cases. */ |
| expr1 = co->expr1; |
| expr2 = co->expr2; |
| |
| if (expr2->expr_type != EXPR_FUNCTION |
| || expr2->value.function.isym == NULL |
| || expr2->value.function.isym->id != GFC_ISYM_MATMUL) |
| return 0; |
| |
| a_tmp = false; |
| a = expr2->value.function.actual; |
| matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); |
| if (matrix_a != NULL) |
| { |
| if (matrix_a->expr_type == EXPR_VARIABLE |
| && (gfc_check_dependency (matrix_a, expr1, true) |
| || gfc_has_dimen_vector_ref (matrix_a))) |
| a_tmp = true; |
| } |
| else |
| a_tmp = true; |
| |
| b_tmp = false; |
| b = a->next; |
| matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); |
| if (matrix_b != NULL) |
| { |
| if (matrix_b->expr_type == EXPR_VARIABLE |
| && (gfc_check_dependency (matrix_b, expr1, true) |
| || gfc_has_dimen_vector_ref (matrix_b))) |
| b_tmp = true; |
| } |
| else |
| b_tmp = true; |
| |
| if (!a_tmp && !b_tmp) |
| return 0; |
| |
| current_code = c; |
| inserted_block = NULL; |
| changed_statement = NULL; |
| if (a_tmp) |
| { |
| gfc_expr *at; |
| at = create_var (a->expr,"mma"); |
| if (at) |
| a->expr = at; |
| } |
| if (b_tmp) |
| { |
| gfc_expr *bt; |
| bt = create_var (b->expr,"mmb"); |
| if (bt) |
| b->expr = bt; |
| } |
| return 0; |
| } |
| |
| /* Auxiliary function to build and simplify an array inquiry function. |
| dim is zero-based. */ |
| |
| static gfc_expr * |
| get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0) |
| { |
| gfc_expr *fcn; |
| gfc_expr *dim_arg, *kind; |
| const char *name; |
| gfc_expr *ec; |
| |
| switch (id) |
| { |
| case GFC_ISYM_LBOUND: |
| name = "_gfortran_lbound"; |
| break; |
| |
| case GFC_ISYM_UBOUND: |
| name = "_gfortran_ubound"; |
| break; |
| |
| case GFC_ISYM_SIZE: |
| name = "_gfortran_size"; |
| break; |
| |
| default: |
| gcc_unreachable (); |
| } |
| |
| dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim); |
| if (okind != 0) |
| kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, |
| okind); |
| else |
| kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, |
| gfc_index_integer_kind); |
| |
| ec = gfc_copy_expr (e); |
| |
| /* No bounds checking, this will be done before the loops if -fcheck=bounds |
| is in effect. */ |
| ec->no_bounds_check = 1; |
| fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3, |
| ec, dim_arg, kind); |
| gfc_simplify_expr (fcn, 0); |
| fcn->no_bounds_check = 1; |
| return fcn; |
| } |
| |
| /* Builds a logical expression. */ |
| |
| static gfc_expr* |
| build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) |
| { |
| gfc_typespec ts; |
| gfc_expr *res; |
| |
| ts.type = BT_LOGICAL; |
| ts.kind = gfc_default_logical_kind; |
| res = gfc_get_expr (); |
| res->where = e1->where; |
| res->expr_type = EXPR_OP; |
| res->value.op.op = op; |
| res->value.op.op1 = e1; |
| res->value.op.op2 = e2; |
| res->ts = ts; |
| |
| return res; |
| } |
| |
| |
| /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes |
| compatible typespecs. */ |
| |
| static gfc_expr * |
| get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) |
| { |
| gfc_expr *res; |
| |
| res = gfc_get_expr (); |
| res->ts = e1->ts; |
| res->where = e1->where; |
| res->expr_type = EXPR_OP; |
| res->value.op.op = op; |
| res->value.op.op1 = e1; |
| res->value.op.op2 = e2; |
| gfc_simplify_expr (res, 0); |
| return res; |
| } |
| |
| /* Generate the IF statement for a runtime check if we want to do inlining or |
| not - putting in the code for both branches and putting it into the syntax |
| tree is the caller's responsibility. For fixed array sizes, this should be |
| removed by DCE. Only called for rank-two matrices A and B. */ |
| |
| static gfc_code * |
| inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a) |
| { |
| gfc_expr *inline_limit; |
| gfc_code *if_1, *if_2, *else_2; |
| gfc_expr *b2, *a2, *a1, *m1, *m2; |
| gfc_typespec ts; |
| gfc_expr *cond; |
| |
| gcc_assert (rank_a == 1 || rank_a == 2); |
| |
| /* Calculation is done in real to avoid integer overflow. */ |
| |
| inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind, |
| &a->where); |
| mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE); |
| |
| /* Set the limit according to the rank. */ |
| mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1, |
| GFC_RND_MODE); |
| |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1); |
| |
| /* For a_rank = 1, must use one as the size of a along the second |
| dimension as to avoid too much code duplication. */ |
| |
| if (rank_a == 2) |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2); |
| else |
| a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1); |
| |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2); |
| |
| gfc_clear_ts (&ts); |
| ts.type = BT_REAL; |
| ts.kind = gfc_default_real_kind; |
| gfc_convert_type_warn (a1, &ts, 2, 0); |
| gfc_convert_type_warn (a2, &ts, 2, 0); |
| gfc_convert_type_warn (b2, &ts, 2, 0); |
| |
| m1 = get_operand (INTRINSIC_TIMES, a1, a2); |
| m2 = get_operand (INTRINSIC_TIMES, m1, b2); |
| |
| cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit); |
| gfc_simplify_expr (cond, 0); |
| |
| else_2 = XCNEW (gfc_code); |
| else_2->op = EXEC_IF; |
| else_2->loc = a->where; |
| |
| if_2 = XCNEW (gfc_code); |
| if_2->op = EXEC_IF; |
| if_2->expr1 = cond; |
| if_2->loc = a->where; |
| if_2->block = else_2; |
| |
| if_1 = XCNEW (gfc_code); |
| if_1->op = EXEC_IF; |
| if_1->block = if_2; |
| if_1->loc = a->where; |
| |
| return if_1; |
| } |
| |
| |
| /* Insert code to issue a runtime error if the expressions are not equal. */ |
| |
| static gfc_code * |
| runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg) |
| { |
| gfc_expr *cond; |
| gfc_code *if_1, *if_2; |
| gfc_code *c; |
| gfc_actual_arglist *a1, *a2, *a3; |
| |
| gcc_assert (e1->where.lb); |
| /* Build the call to runtime_error. */ |
| c = XCNEW (gfc_code); |
| c->op = EXEC_CALL; |
| c->loc = e1->where; |
| |
| /* Get a null-terminated message string. */ |
| |
| a1 = gfc_get_actual_arglist (); |
| a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where, |
| msg, strlen(msg)+1); |
| c->ext.actual = a1; |
| |
| /* Pass the value of the first expression. */ |
| a2 = gfc_get_actual_arglist (); |
| a2->expr = gfc_copy_expr (e1); |
| a1->next = a2; |
| |
| /* Pass the value of the second expression. */ |
| a3 = gfc_get_actual_arglist (); |
| a3->expr = gfc_copy_expr (e2); |
| a2->next = a3; |
| |
| gfc_check_fe_runtime_error (c->ext.actual); |
| gfc_resolve_fe_runtime_error (c); |
| |
| if_2 = XCNEW (gfc_code); |
| if_2->op = EXEC_IF; |
| if_2->loc = e1->where; |
| if_2->next = c; |
| |
| if_1 = XCNEW (gfc_code); |
| if_1->op = EXEC_IF; |
| if_1->block = if_2; |
| if_1->loc = e1->where; |
| |
| cond = build_logical_expr (INTRINSIC_NE, e1, e2); |
| gfc_simplify_expr (cond, 0); |
| if_2->expr1 = cond; |
| |
| return if_1; |
| } |
| |
| /* Handle matrix reallocation. Caller is responsible to insert into |
| the code tree. |
| |
| For the two-dimensional case, build |
| |
| if (allocated(c)) then |
| if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then |
| deallocate(c) |
| allocate (c(size(a,1), size(b,2))) |
| end if |
| else |
| allocate (c(size(a,1),size(b,2))) |
| end if |
| |
| and for the other cases correspondingly. |
| */ |
| |
| static gfc_code * |
| matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b, |
| enum matrix_case m_case) |
| { |
| |
| gfc_expr *allocated, *alloc_expr; |
| gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2; |
| gfc_code *else_alloc; |
| gfc_code *deallocate, *allocate1, *allocate_else; |
| gfc_array_ref *ar; |
| gfc_expr *cond, *ne1, *ne2; |
| |
| if (warn_realloc_lhs) |
| gfc_warning (OPT_Wrealloc_lhs, |
| "Code for reallocating the allocatable array at %L will " |
| "be added", &c->where); |
| |
| alloc_expr = gfc_copy_expr (c); |
| |
| ar = gfc_find_array_ref (alloc_expr); |
| gcc_assert (ar && ar->type == AR_FULL); |
| |
| /* c comes in as a full ref. Change it into a copy and make it into an |
| element ref so it has the right form for ALLOCATE. In the same |
| switch statement, also generate the size comparison for the secod IF |
| statement. */ |
| |
| ar->type = AR_ELEMENT; |
| |
| switch (m_case) |
| { |
| case A2B2: |
| ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); |
| ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); |
| ne1 = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 1), |
| get_array_inq_function (GFC_ISYM_SIZE, a, 1)); |
| ne2 = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 2), |
| get_array_inq_function (GFC_ISYM_SIZE, b, 2)); |
| cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); |
| break; |
| |
| case A2B2T: |
| ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); |
| ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); |
| |
| ne1 = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 1), |
| get_array_inq_function (GFC_ISYM_SIZE, a, 1)); |
| ne2 = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 2), |
| get_array_inq_function (GFC_ISYM_SIZE, b, 1)); |
| cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); |
| break; |
| |
| case A2TB2: |
| |
| ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2); |
| ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); |
| |
| ne1 = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 1), |
| get_array_inq_function (GFC_ISYM_SIZE, a, 2)); |
| ne2 = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 2), |
| get_array_inq_function (GFC_ISYM_SIZE, b, 2)); |
| cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); |
| break; |
| |
| case A2B1: |
| ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); |
| cond = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 1), |
| get_array_inq_function (GFC_ISYM_SIZE, a, 2)); |
| break; |
| |
| case A1B2: |
| ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); |
| cond = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 1), |
| get_array_inq_function (GFC_ISYM_SIZE, b, 2)); |
| break; |
| |
| case A2TB2T: |
| /* This can only happen for BLAS, we do not handle that case in |
| inline mamtul. */ |
| ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2); |
| ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); |
| |
| ne1 = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 1), |
| get_array_inq_function (GFC_ISYM_SIZE, a, 2)); |
| ne2 = build_logical_expr (INTRINSIC_NE, |
| get_array_inq_function (GFC_ISYM_SIZE, c, 2), |
| get_array_inq_function (GFC_ISYM_SIZE, b, 1)); |
| |
| cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); |
| break; |
| |
| default: |
| gcc_unreachable(); |
| |
| } |
| |
| gfc_simplify_expr (cond, 0); |
| |
| /* We need two identical allocate statements in two |
| branches of the IF statement. */ |
| |
| allocate1 = XCNEW (gfc_code); |
| allocate1->op = EXEC_ALLOCATE; |
| allocate1->ext.alloc.list = gfc_get_alloc (); |
| allocate1->loc = c->where; |
| allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr); |
| |
| allocate_else = XCNEW (gfc_code); |
| allocate_else->op = EXEC_ALLOCATE; |
| allocate_else->ext.alloc.list = gfc_get_alloc (); |
| allocate_else->loc = c->where; |
| allocate_else->ext.alloc.list->expr = alloc_expr; |
| |
| allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED, |
| "_gfortran_allocated", c->where, |
| 1, gfc_copy_expr (c)); |
| |
| deallocate = XCNEW (gfc_code); |
| deallocate->op = EXEC_DEALLOCATE; |
| deallocate->ext.alloc.list = gfc_get_alloc (); |
| deallocate->ext.alloc.list->expr = gfc_copy_expr (c); |
| deallocate->next = allocate1; |
| deallocate->loc = c->where; |
| |
| if_size_2 = XCNEW (gfc_code); |
| if_size_2->op = EXEC_IF; |
| if_size_2->expr1 = cond; |
| if_size_2->loc = c->where; |
| if_size_2->next = deallocate; |
| |
| if_size_1 = XCNEW (gfc_code); |
| if_size_1->op = EXEC_IF; |
| if_size_1->block = if_size_2; |
| if_size_1->loc = c->where; |
| |
| else_alloc = XCNEW (gfc_code); |
| else_alloc->op = EXEC_IF; |
| else_alloc->loc = c->where; |
| else_alloc->next = allocate_else; |
| |
| if_alloc_2 = XCNEW (gfc_code); |
| if_alloc_2->op = EXEC_IF; |
| if_alloc_2->expr1 = allocated; |
| if_alloc_2->loc = c->where; |
| if_alloc_2->next = if_size_1; |
| if_alloc_2->block = else_alloc; |
| |
| if_alloc_1 = XCNEW (gfc_code); |
| if_alloc_1->op = EXEC_IF; |
| if_alloc_1->block = if_alloc_2; |
| if_alloc_1->loc = c->where; |
| |
| return if_alloc_1; |
| } |
| |
| /* Callback function for has_function_or_op. */ |
| |
| static int |
| is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| if ((*e) == 0) |
| return 0; |
| else |
| return (*e)->expr_type == EXPR_FUNCTION |
| || (*e)->expr_type == EXPR_OP; |
| } |
| |
| /* Returns true if the expression contains a function. */ |
| |
| static bool |
| has_function_or_op (gfc_expr **e) |
| { |
| if (e == NULL) |
| return false; |
| else |
| return gfc_expr_walker (e, is_function_or_op, NULL); |
| } |
| |
| /* Freeze (assign to a temporary variable) a single expression. */ |
| |
| static void |
| freeze_expr (gfc_expr **ep) |
| { |
| gfc_expr *ne; |
| if (has_function_or_op (ep)) |
| { |
| ne = create_var (*ep, "freeze"); |
| *ep = ne; |
| } |
| } |
| |
| /* Go through an expression's references and assign them to temporary |
| variables if they contain functions. This is usually done prior to |
| front-end scalarization to avoid multiple invocations of functions. */ |
| |
| static void |
| freeze_references (gfc_expr *e) |
| { |
| gfc_ref *r; |
| gfc_array_ref *ar; |
| int i; |
| |
| for (r=e->ref; r; r=r->next) |
| { |
| if (r->type == REF_SUBSTRING) |
| { |
| if (r->u.ss.start != NULL) |
| freeze_expr (&r->u.ss.start); |
| |
| if (r->u.ss.end != NULL) |
| freeze_expr (&r->u.ss.end); |
| } |
| else if (r->type == REF_ARRAY) |
| { |
| ar = &r->u.ar; |
| switch (ar->type) |
| { |
| case AR_FULL: |
| break; |
| |
| case AR_SECTION: |
| for (i=0; i<ar->dimen; i++) |
| { |
| if (ar->dimen_type[i] == DIMEN_RANGE) |
| { |
| freeze_expr (&ar->start[i]); |
| freeze_expr (&ar->end[i]); |
| freeze_expr (&ar->stride[i]); |
| } |
| else if (ar->dimen_type[i] == DIMEN_ELEMENT) |
| { |
| freeze_expr (&ar->start[i]); |
| } |
| } |
| break; |
| |
| case AR_ELEMENT: |
| for (i=0; i<ar->dimen; i++) |
| freeze_expr (&ar->start[i]); |
| break; |
| |
| default: |
| break; |
| } |
| } |
| } |
| } |
| |
| /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */ |
| |
| static gfc_expr * |
| convert_to_index_kind (gfc_expr *e) |
| { |
| gfc_expr *res; |
| |
| gcc_assert (e != NULL); |
| |
| res = gfc_copy_expr (e); |
| |
| gcc_assert (e->ts.type == BT_INTEGER); |
| |
| if (res->ts.kind != gfc_index_integer_kind) |
| { |
| gfc_typespec ts; |
| gfc_clear_ts (&ts); |
| ts.type = BT_INTEGER; |
| ts.kind = gfc_index_integer_kind; |
| |
| gfc_convert_type_warn (e, &ts, 2, 0); |
| } |
| |
| return res; |
| } |
| |
| /* Function to create a DO loop including creation of the |
| iteration variable. gfc_expr are copied.*/ |
| |
| static gfc_code * |
| create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where, |
| gfc_namespace *ns, char *vname) |
| { |
| |
| char name[GFC_MAX_SYMBOL_LEN +1]; |
| gfc_symtree *symtree; |
| gfc_symbol *symbol; |
| gfc_expr *i; |
| gfc_code *n, *n2; |
| |
| /* Create an expression for the iteration variable. */ |
| if (vname) |
| sprintf (name, "__var_%d_do_%s", var_num++, vname); |
| else |
| sprintf (name, "__var_%d_do", var_num++); |
| |
| |
| if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) |
| gcc_unreachable (); |
| |
| /* Create the loop variable. */ |
| |
| symbol = symtree->n.sym; |
| symbol->ts.type = BT_INTEGER; |
| symbol->ts.kind = gfc_index_integer_kind; |
| symbol->attr.flavor = FL_VARIABLE; |
| symbol->attr.referenced = 1; |
| symbol->attr.dimension = 0; |
| symbol->attr.fe_temp = 1; |
| gfc_commit_symbol (symbol); |
| |
| i = gfc_get_expr (); |
| i->expr_type = EXPR_VARIABLE; |
| i->ts = symbol->ts; |
| i->rank = 0; |
| i->where = *where; |
| i->symtree = symtree; |
| |
| /* ... and the nested DO statements. */ |
| n = XCNEW (gfc_code); |
| n->op = EXEC_DO; |
| n->loc = *where; |
| n->ext.iterator = gfc_get_iterator (); |
| n->ext.iterator->var = i; |
| n->ext.iterator->start = convert_to_index_kind (start); |
| n->ext.iterator->end = convert_to_index_kind (end); |
| if (step) |
| n->ext.iterator->step = convert_to_index_kind (step); |
| else |
| n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind, |
| where, 1); |
| |
| n2 = XCNEW (gfc_code); |
| n2->op = EXEC_DO; |
| n2->loc = *where; |
| n2->next = NULL; |
| n->block = n2; |
| return n; |
| } |
| |
| /* Get the upper bound of the DO loops for matmul along a dimension. This |
| is one-based. */ |
| |
| static gfc_expr* |
| get_size_m1 (gfc_expr *e, int dimen) |
| { |
| mpz_t size; |
| gfc_expr *res; |
| |
| if (gfc_array_dimen_size (e, dimen - 1, &size)) |
| { |
| res = gfc_get_constant_expr (BT_INTEGER, |
| gfc_index_integer_kind, &e->where); |
| mpz_sub_ui (res->value.integer, size, 1); |
| mpz_clear (size); |
| } |
| else |
| { |
| res = get_operand (INTRINSIC_MINUS, |
| get_array_inq_function (GFC_ISYM_SIZE, e, dimen), |
| gfc_get_int_expr (gfc_index_integer_kind, |
| &e->where, 1)); |
| gfc_simplify_expr (res, 0); |
| } |
| |
| return res; |
| } |
| |
| /* Function to return a scalarized expression. It is assumed that indices are |
| zero based to make generation of DO loops easier. A zero as index will |
| access the first element along a dimension. Single element references will |
| be skipped. A NULL as an expression will be replaced by a full reference. |
| This assumes that the index loops have gfc_index_integer_kind, and that all |
| references have been frozen. */ |
| |
| static gfc_expr* |
| scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) |
| { |
| gfc_array_ref *ar; |
| int i; |
| int rank; |
| gfc_expr *e; |
| int i_index; |
| bool was_fullref; |
| |
| e = gfc_copy_expr(e_in); |
| |
| rank = e->rank; |
| |
| ar = gfc_find_array_ref (e); |
| |
| /* We scalarize count_index variables, reducing the rank by count_index. */ |
| |
| e->rank = rank - count_index; |
| |
| was_fullref = ar->type == AR_FULL; |
| |
| if (e->rank == 0) |
| ar->type = AR_ELEMENT; |
| else |
| ar->type = AR_SECTION; |
| |
| /* Loop over the indices. For each index, create the expression |
| index * stride + lbound(e, dim). */ |
| |
| i_index = 0; |
| for (i=0; i < ar->dimen; i++) |
| { |
| if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE) |
| { |
| if (index[i_index] != NULL) |
| { |
| gfc_expr *lbound, *nindex; |
| gfc_expr *loopvar; |
| |
| loopvar = gfc_copy_expr (index[i_index]); |
| |
| if (ar->stride[i]) |
| { |
| gfc_expr *tmp; |
| |
| tmp = gfc_copy_expr(ar->stride[i]); |
| if (tmp->ts.kind != gfc_index_integer_kind) |
| { |
| gfc_typespec ts; |
| gfc_clear_ts (&ts); |
| ts.type = BT_INTEGER; |
| ts.kind = gfc_index_integer_kind; |
| gfc_convert_type (tmp, &ts, 2); |
| } |
| nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp); |
| } |
| else |
| nindex = loopvar; |
| |
| /* Calculate the lower bound of the expression. */ |
| if (ar->start[i]) |
| { |
| lbound = gfc_copy_expr (ar->start[i]); |
| if (lbound->ts.kind != gfc_index_integer_kind) |
| { |
| gfc_typespec ts; |
| gfc_clear_ts (&ts); |
| ts.type = BT_INTEGER; |
| ts.kind = gfc_index_integer_kind; |
| gfc_convert_type (lbound, &ts, 2); |
| |
| } |
| } |
| else |
| { |
| gfc_expr *lbound_e; |
| gfc_ref *ref; |
| |
| lbound_e = gfc_copy_expr (e_in); |
| |
| for (ref = lbound_e->ref; ref; ref = ref->next) |
| if (ref->type == REF_ARRAY |
| && (ref->u.ar.type == AR_FULL |
| || ref->u.ar.type == AR_SECTION)) |
| break; |
| |
| if (ref->next) |
| { |
| gfc_free_ref_list (ref->next); |
| ref->next = NULL; |
| } |
| |
| if (!was_fullref) |
| { |
| /* Look at full individual sections, like a(:). The first index |
| is the lbound of a full ref. */ |
| int j; |
| gfc_array_ref *ar; |
| int to; |
| |
| ar = &ref->u.ar; |
| |
| /* For assumed size, we need to keep around the final |
| reference in order not to get an error on resolution |
| below, and we cannot use AR_FULL. */ |
| |
| if (ar->as->type == AS_ASSUMED_SIZE) |
| { |
| ar->type = AR_SECTION; |
| to = ar->dimen - 1; |
| } |
| else |
| { |
| to = ar->dimen; |
| ar->type = AR_FULL; |
| } |
| |
| for (j = 0; j < to; j++) |
| { |
| gfc_free_expr (ar->start[j]); |
| ar->start[j] = NULL; |
| gfc_free_expr (ar->end[j]); |
| ar->end[j] = NULL; |
| gfc_free_expr (ar->stride[j]); |
| ar->stride[j] = NULL; |
| } |
| |
| /* We have to get rid of the shape, if there is one. Do |
| so by freeing it and calling gfc_resolve to rebuild |
| it, if necessary. */ |
| |
| if (lbound_e->shape) |
| gfc_free_shape (&(lbound_e->shape), lbound_e->rank); |
| |
| lbound_e->rank = ar->dimen; |
| gfc_resolve_expr (lbound_e); |
| } |
| lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e, |
| i + 1); |
| gfc_free_expr (lbound_e); |
| } |
| |
| ar->dimen_type[i] = DIMEN_ELEMENT; |
| |
| gfc_free_expr (ar->start[i]); |
| ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound); |
| |
| gfc_free_expr (ar->end[i]); |
| ar->end[i] = NULL; |
| gfc_free_expr (ar->stride[i]); |
| ar->stride[i] = NULL; |
| gfc_simplify_expr (ar->start[i], 0); |
| } |
| else if (was_fullref) |
| { |
| gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented"); |
| } |
| i_index ++; |
| } |
| } |
| |
| /* Bounds checking will be done before the loops if -fcheck=bounds |
| is in effect. */ |
| e->no_bounds_check = 1; |
| return e; |
| } |
| |
| /* Helper function to check for a dimen vector as subscript. */ |
| |
| bool |
| gfc_has_dimen_vector_ref (gfc_expr *e) |
| { |
| gfc_array_ref *ar; |
| int i; |
| |
| ar = gfc_find_array_ref (e); |
| gcc_assert (ar); |
| if (ar->type == AR_FULL) |
| return false; |
| |
| for (i=0; i<ar->dimen; i++) |
| if (ar->dimen_type[i] == DIMEN_VECTOR) |
| return true; |
| |
| return false; |
| } |
| |
| /* If handed an expression of the form |
| |
| TRANSPOSE(CONJG(A)) |
| |
| check if A can be handled by matmul and return if there is an uneven number |
| of CONJG calls. Return a pointer to the array when everything is OK, NULL |
| otherwise. The caller has to check for the correct rank. */ |
| |
| static gfc_expr* |
| check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose) |
| { |
| *conjg = false; |
| *transpose = false; |
| |
| do |
| { |
| if (e->expr_type == EXPR_VARIABLE) |
| { |
| gcc_assert (e->rank == 1 || e->rank == 2); |
| return e; |
| } |
| else if (e->expr_type == EXPR_FUNCTION) |
| { |
| if (e->value.function.isym == NULL) |
| return NULL; |
| |
| if (e->value.function.isym->id == GFC_ISYM_CONJG) |
| *conjg = !*conjg; |
| else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE) |
| *transpose = !*transpose; |
| else return NULL; |
| } |
| else |
| return NULL; |
| |
| e = e->value.function.actual->expr; |
| } |
| while(1); |
| |
| return NULL; |
| } |
| |
| /* Macros for unified error messages. */ |
| |
| #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \ |
| "dimension 1: is %ld, should be %ld") |
| |
| #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \ |
| "(%ld/%ld)") |
| |
| #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \ |
| "(%ld/%ld)") |
| |
| |
| /* Inline assignments of the form c = matmul(a,b). |
| Handle only the cases currently where b and c are rank-two arrays. |
| |
| This basically translates the code to |
| |
| BLOCK |
| integer i,j,k |
| c = 0 |
| do j=0, size(b,2)-1 |
| do k=0, size(a, 2)-1 |
| do i=0, size(a, 1)-1 |
| c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) = |
| c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) + |
| a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) * |
| b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2)) |
| end do |
| end do |
| end do |
| END BLOCK |
| |
| */ |
| |
| static int |
| inline_matmul_assign (gfc_code **c, int *walk_subtrees, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_code *co = *c; |
| gfc_expr *expr1, *expr2; |
| gfc_expr *matrix_a, *matrix_b; |
| gfc_actual_arglist *a, *b; |
| gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul; |
| gfc_expr *zero_e; |
| gfc_expr *u1, *u2, *u3; |
| gfc_expr *list[2]; |
| gfc_expr *ascalar, *bscalar, *cscalar; |
| gfc_expr *mult; |
| gfc_expr *var_1, *var_2, *var_3; |
| gfc_expr *zero; |
| gfc_namespace *ns; |
| gfc_intrinsic_op op_times, op_plus; |
| enum matrix_case m_case; |
| int i; |
| gfc_code *if_limit = NULL; |
| gfc_code **next_code_point; |
| bool conjg_a, conjg_b, transpose_a, transpose_b; |
| bool realloc_c; |
| |
| if (co->op != EXEC_ASSIGN) |
| return 0; |
| |
| if (in_where || in_assoc_list) |
| return 0; |
| |
| /* The BLOCKS generated for the temporary variables and FORALL don't |
| mix. */ |
| if (forall_level > 0) |
| return 0; |
| |
| /* For now don't do anything in OpenMP workshare, it confuses |
| its translation, which expects only the allowed statements in there. |
| We should figure out how to parallelize this eventually. */ |
| if (in_omp_workshare || in_omp_atomic) |
| return 0; |
| |
| expr1 = co->expr1; |
| expr2 = co->expr2; |
| if (expr2->expr_type != EXPR_FUNCTION |
| || expr2->value.function.isym == NULL |
| || expr2->value.function.isym->id != GFC_ISYM_MATMUL) |
| return 0; |
| |
| current_code = c; |
| inserted_block = NULL; |
| changed_statement = NULL; |
| |
| a = expr2->value.function.actual; |
| matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); |
| if (matrix_a == NULL) |
| return 0; |
| |
| b = a->next; |
| matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); |
| if (matrix_b == NULL) |
| return 0; |
| |
| if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a) |
| || gfc_has_dimen_vector_ref (matrix_b)) |
| return 0; |
| |
| /* We do not handle data dependencies yet. */ |
| if (gfc_check_dependency (expr1, matrix_a, true) |
| || gfc_check_dependency (expr1, matrix_b, true)) |
| return 0; |
| |
| m_case = none; |
| if (matrix_a->rank == 2) |
| { |
| if (transpose_a) |
| { |
| if (matrix_b->rank == 2 && !transpose_b) |
| m_case = A2TB2; |
| } |
| else |
| { |
| if (matrix_b->rank == 1) |
| m_case = A2B1; |
| else /* matrix_b->rank == 2 */ |
| { |
| if (transpose_b) |
| m_case = A2B2T; |
| else |
| m_case = A2B2; |
| } |
| } |
| } |
| else /* matrix_a->rank == 1 */ |
| { |
| if (matrix_b->rank == 2) |
| { |
| if (!transpose_b) |
| m_case = A1B2; |
| } |
| } |
| |
| if (m_case == none) |
| return 0; |
| |
| /* We only handle assignment to numeric or logical variables. */ |
| switch(expr1->ts.type) |
| { |
| case BT_INTEGER: |
| case BT_LOGICAL: |
| case BT_REAL: |
| case BT_COMPLEX: |
| break; |
| |
| default: |
| return 0; |
| } |
| |
| ns = insert_block (); |
| |
| /* Assign the type of the zero expression for initializing the resulting |
| array, and the expression (+ and * for real, integer and complex; |
| .and. and .or for logical. */ |
| |
| switch(expr1->ts.type) |
| { |
| case BT_INTEGER: |
| zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0); |
| op_times = INTRINSIC_TIMES; |
| op_plus = INTRINSIC_PLUS; |
| break; |
| |
| case BT_LOGICAL: |
| op_times = INTRINSIC_AND; |
| op_plus = INTRINSIC_OR; |
| zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where, |
| 0); |
| break; |
| case BT_REAL: |
| zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind, |
| &expr1->where); |
| mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE); |
| op_times = INTRINSIC_TIMES; |
| op_plus = INTRINSIC_PLUS; |
| break; |
| |
| case BT_COMPLEX: |
| zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind, |
| &expr1->where); |
| mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE); |
| op_times = INTRINSIC_TIMES; |
| op_plus = INTRINSIC_PLUS; |
| |
| break; |
| |
| default: |
| gcc_unreachable(); |
| } |
| |
| current_code = &ns->code; |
| |
| /* Freeze the references, keeping track of how many temporary variables were |
| created. */ |
| n_vars = 0; |
| freeze_references (matrix_a); |
| freeze_references (matrix_b); |
| freeze_references (expr1); |
| |
| if (n_vars == 0) |
| next_code_point = current_code; |
| else |
| { |
| next_code_point = &ns->code; |
| for (i=0; i<n_vars; i++) |
| next_code_point = &(*next_code_point)->next; |
| } |
| |
| /* Take care of the inline flag. If the limit check evaluates to a |
| constant, dead code elimination will eliminate the unneeded branch. */ |
| |
| if (flag_inline_matmul_limit > 0 |
| && (matrix_a->rank == 1 || matrix_a->rank == 2) |
| && matrix_b->rank == 2) |
| { |
| if_limit = inline_limit_check (matrix_a, matrix_b, |
| flag_inline_matmul_limit, |
| matrix_a->rank); |
| |
| /* Insert the original statement into the else branch. */ |
| if_limit->block->block->next = co; |
| co->next = NULL; |
| |
| /* ... and the new ones go into the original one. */ |
| *next_code_point = if_limit; |
| next_code_point = &if_limit->block->next; |
| } |
| |
| zero_e->no_bounds_check = 1; |
| |
| assign_zero = XCNEW (gfc_code); |
| assign_zero->op = EXEC_ASSIGN; |
| assign_zero->loc = co->loc; |
| assign_zero->expr1 = gfc_copy_expr (expr1); |
| assign_zero->expr1->no_bounds_check = 1; |
| assign_zero->expr2 = zero_e; |
| |
| realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1); |
| |
| if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) |
| { |
| gfc_code *test; |
| gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; |
| |
| switch (m_case) |
| { |
| case A2B1: |
| |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); |
| test = runtime_error_ne (b1, a2, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (c1, a1, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| case A1B2: |
| |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (b1, a1, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); |
| test = runtime_error_ne (c1, b2, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| case A2B2: |
| |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); |
| test = runtime_error_ne (b1, a2, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (c1, a1, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); |
| test = runtime_error_ne (c2, b2, C_ERROR_2); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| case A2B2T: |
| |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); |
| /* matrix_b is transposed, hence dimension 1 for the error message. */ |
| test = runtime_error_ne (b2, a2, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (c1, a1, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| test = runtime_error_ne (c2, b1, C_ERROR_2); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| case A2TB2: |
| |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (b1, a1, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); |
| test = runtime_error_ne (c1, a2, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); |
| test = runtime_error_ne (c2, b2, C_ERROR_2); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| default: |
| gcc_unreachable (); |
| } |
| } |
| |
| /* Handle the reallocation, if needed. */ |
| |
| if (realloc_c) |
| { |
| gfc_code *lhs_alloc; |
| |
| lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); |
| |
| *next_code_point = lhs_alloc; |
| next_code_point = &lhs_alloc->next; |
| |
| } |
| |
| *next_code_point = assign_zero; |
| |
| zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0); |
| |
| assign_matmul = XCNEW (gfc_code); |
| assign_matmul->op = EXEC_ASSIGN; |
| assign_matmul->loc = co->loc; |
| |
| /* Get the bounds for the loops, create them and create the scalarized |
| expressions. */ |
| |
| switch (m_case) |
| { |
| case A2B2: |
| |
| u1 = get_size_m1 (matrix_b, 2); |
| u2 = get_size_m1 (matrix_a, 2); |
| u3 = get_size_m1 (matrix_a, 1); |
| |
| do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); |
| do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); |
| do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); |
| |
| do_1->block->next = do_2; |
| do_2->block->next = do_3; |
| do_3->block->next = assign_matmul; |
| |
| var_1 = do_1->ext.iterator->var; |
| var_2 = do_2->ext.iterator->var; |
| var_3 = do_3->ext.iterator->var; |
| |
| list[0] = var_3; |
| list[1] = var_1; |
| cscalar = scalarized_expr (co->expr1, list, 2); |
| |
| list[0] = var_3; |
| list[1] = var_2; |
| ascalar = scalarized_expr (matrix_a, list, 2); |
| |
| list[0] = var_2; |
| list[1] = var_1; |
| bscalar = scalarized_expr (matrix_b, list, 2); |
| |
| break; |
| |
| case A2B2T: |
| |
| u1 = get_size_m1 (matrix_b, 1); |
| u2 = get_size_m1 (matrix_a, 2); |
| u3 = get_size_m1 (matrix_a, 1); |
| |
| do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); |
| do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); |
| do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); |
| |
| do_1->block->next = do_2; |
| do_2->block->next = do_3; |
| do_3->block->next = assign_matmul; |
| |
| var_1 = do_1->ext.iterator->var; |
| var_2 = do_2->ext.iterator->var; |
| var_3 = do_3->ext.iterator->var; |
| |
| list[0] = var_3; |
| list[1] = var_1; |
| cscalar = scalarized_expr (co->expr1, list, 2); |
| |
| list[0] = var_3; |
| list[1] = var_2; |
| ascalar = scalarized_expr (matrix_a, list, 2); |
| |
| list[0] = var_1; |
| list[1] = var_2; |
| bscalar = scalarized_expr (matrix_b, list, 2); |
| |
| break; |
| |
| case A2TB2: |
| |
| u1 = get_size_m1 (matrix_a, 2); |
| u2 = get_size_m1 (matrix_b, 2); |
| u3 = get_size_m1 (matrix_a, 1); |
| |
| do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); |
| do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); |
| do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); |
| |
| do_1->block->next = do_2; |
| do_2->block->next = do_3; |
| do_3->block->next = assign_matmul; |
| |
| var_1 = do_1->ext.iterator->var; |
| var_2 = do_2->ext.iterator->var; |
| var_3 = do_3->ext.iterator->var; |
| |
| list[0] = var_1; |
| list[1] = var_2; |
| cscalar = scalarized_expr (co->expr1, list, 2); |
| |
| list[0] = var_3; |
| list[1] = var_1; |
| ascalar = scalarized_expr (matrix_a, list, 2); |
| |
| list[0] = var_3; |
| list[1] = var_2; |
| bscalar = scalarized_expr (matrix_b, list, 2); |
| |
| break; |
| |
| case A2B1: |
| u1 = get_size_m1 (matrix_b, 1); |
| u2 = get_size_m1 (matrix_a, 1); |
| |
| do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); |
| do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); |
| |
| do_1->block->next = do_2; |
| do_2->block->next = assign_matmul; |
| |
| var_1 = do_1->ext.iterator->var; |
| var_2 = do_2->ext.iterator->var; |
| |
| list[0] = var_2; |
| cscalar = scalarized_expr (co->expr1, list, 1); |
| |
| list[0] = var_2; |
| list[1] = var_1; |
| ascalar = scalarized_expr (matrix_a, list, 2); |
| |
| list[0] = var_1; |
| bscalar = scalarized_expr (matrix_b, list, 1); |
| |
| break; |
| |
| case A1B2: |
| u1 = get_size_m1 (matrix_b, 2); |
| u2 = get_size_m1 (matrix_a, 1); |
| |
| do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); |
| do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); |
| |
| do_1->block->next = do_2; |
| do_2->block->next = assign_matmul; |
| |
| var_1 = do_1->ext.iterator->var; |
| var_2 = do_2->ext.iterator->var; |
| |
| list[0] = var_1; |
| cscalar = scalarized_expr (co->expr1, list, 1); |
| |
| list[0] = var_2; |
| ascalar = scalarized_expr (matrix_a, list, 1); |
| |
| list[0] = var_2; |
| list[1] = var_1; |
| bscalar = scalarized_expr (matrix_b, list, 2); |
| |
| break; |
| |
| default: |
| gcc_unreachable(); |
| } |
| |
| /* Build the conjg call around the variables. Set the typespec manually |
| because gfc_build_intrinsic_call sometimes gets this wrong. */ |
| if (conjg_a) |
| { |
| gfc_typespec ts; |
| ts = matrix_a->ts; |
| ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", |
| matrix_a->where, 1, ascalar); |
| ascalar->ts = ts; |
| } |
| |
| if (conjg_b) |
| { |
| gfc_typespec ts; |
| ts = matrix_b->ts; |
| bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", |
| matrix_b->where, 1, bscalar); |
| bscalar->ts = ts; |
| } |
| /* First loop comes after the zero assignment. */ |
| assign_zero->next = do_1; |
| |
| /* Build the assignment expression in the loop. */ |
| assign_matmul->expr1 = gfc_copy_expr (cscalar); |
| |
| mult = get_operand (op_times, ascalar, bscalar); |
| assign_matmul->expr2 = get_operand (op_plus, cscalar, mult); |
| |
| /* If we don't want to keep the original statement around in |
| the else branch, we can free it. */ |
| |
| if (if_limit == NULL) |
| gfc_free_statements(co); |
| else |
| co->next = NULL; |
| |
| gfc_free_expr (zero); |
| *walk_subtrees = 0; |
| return 0; |
| } |
| |
| /* Change matmul function calls in the form of |
| |
| c = matmul(a,b) |
| |
| to the corresponding call to a BLAS routine, if applicable. */ |
| |
| static int |
| call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_code *co, *co_next; |
| gfc_expr *expr1, *expr2; |
| gfc_expr *matrix_a, *matrix_b; |
| gfc_code *if_limit = NULL; |
| gfc_actual_arglist *a, *b; |
| bool conjg_a, conjg_b, transpose_a, transpose_b; |
| gfc_code *call; |
| const char *blas_name; |
| const char *transa, *transb; |
| gfc_expr *c1, *c2, *b1; |
| gfc_actual_arglist *actual, *next; |
| bt type; |
| int kind; |
| enum matrix_case m_case; |
| bool realloc_c; |
| gfc_code **next_code_point; |
| |
| /* Many of the tests for inline matmul also apply here. */ |
| |
| co = *c; |
| |
| if (co->op != EXEC_ASSIGN) |
| return 0; |
| |
| if (in_where || in_assoc_list) |
| return 0; |
| |
| /* The BLOCKS generated for the temporary variables and FORALL don't |
| mix. */ |
| if (forall_level > 0) |
| return 0; |
| |
| /* For now don't do anything in OpenMP workshare, it confuses |
| its translation, which expects only the allowed statements in there. */ |
| |
| if (in_omp_workshare || in_omp_atomic) |
| return 0; |
| |
| expr1 = co->expr1; |
| expr2 = co->expr2; |
| if (expr2->expr_type != EXPR_FUNCTION |
| || expr2->value.function.isym == NULL |
| || expr2->value.function.isym->id != GFC_ISYM_MATMUL) |
| return 0; |
| |
| type = expr2->ts.type; |
| kind = expr2->ts.kind; |
| |
| /* Guard against recursion. */ |
| |
| if (expr2->external_blas) |
| return 0; |
| |
| if (type != expr1->ts.type || kind != expr1->ts.kind) |
| return 0; |
| |
| if (type == BT_REAL) |
| { |
| if (kind == 4) |
| blas_name = "sgemm"; |
| else if (kind == 8) |
| blas_name = "dgemm"; |
| else |
| return 0; |
| } |
| else if (type == BT_COMPLEX) |
| { |
| if (kind == 4) |
| blas_name = "cgemm"; |
| else if (kind == 8) |
| blas_name = "zgemm"; |
| else |
| return 0; |
| } |
| else |
| return 0; |
| |
| a = expr2->value.function.actual; |
| if (a->expr->rank != 2) |
| return 0; |
| |
| b = a->next; |
| if (b->expr->rank != 2) |
| return 0; |
| |
| matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); |
| if (matrix_a == NULL) |
| return 0; |
| |
| if (transpose_a) |
| { |
| if (conjg_a) |
| transa = "C"; |
| else |
| transa = "T"; |
| } |
| else |
| transa = "N"; |
| |
| matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); |
| if (matrix_b == NULL) |
| return 0; |
| |
| if (transpose_b) |
| { |
| if (conjg_b) |
| transb = "C"; |
| else |
| transb = "T"; |
| } |
| else |
| transb = "N"; |
| |
| if (transpose_a) |
| { |
| if (transpose_b) |
| m_case = A2TB2T; |
| else |
| m_case = A2TB2; |
| } |
| else |
| { |
| if (transpose_b) |
| m_case = A2B2T; |
| else |
| m_case = A2B2; |
| } |
| |
| current_code = c; |
| inserted_block = NULL; |
| changed_statement = NULL; |
| |
| expr2->external_blas = 1; |
| |
| /* We do not handle data dependencies yet. */ |
| if (gfc_check_dependency (expr1, matrix_a, true) |
| || gfc_check_dependency (expr1, matrix_b, true)) |
| return 0; |
| |
| /* Generate the if statement and hang it into the tree. */ |
| if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2); |
| co_next = co->next; |
| (*current_code) = if_limit; |
| co->next = NULL; |
| if_limit->block->next = co; |
| |
| call = XCNEW (gfc_code); |
| call->loc = co->loc; |
| |
| /* Bounds checking - a bit simpler than for inlining since we only |
| have to take care of two-dimensional arrays here. */ |
| |
| realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1); |
| next_code_point = &(if_limit->block->block->next); |
| |
| if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) |
| { |
| gfc_code *test; |
| // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; |
| gfc_expr *c1, *a1, *c2, *b2, *a2; |
| switch (m_case) |
| { |
| case A2B2: |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); |
| test = runtime_error_ne (b1, a2, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (c1, a1, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); |
| test = runtime_error_ne (c2, b2, C_ERROR_2); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| case A2B2T: |
| |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); |
| /* matrix_b is transposed, hence dimension 1 for the error message. */ |
| test = runtime_error_ne (b2, a2, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (c1, a1, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| test = runtime_error_ne (c2, b1, C_ERROR_2); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| case A2TB2: |
| |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (b1, a1, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); |
| test = runtime_error_ne (c1, a2, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); |
| test = runtime_error_ne (c2, b2, C_ERROR_2); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| case A2TB2T: |
| b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); |
| a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); |
| test = runtime_error_ne (b2, a1, B_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| if (!realloc_c) |
| { |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); |
| a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); |
| test = runtime_error_ne (c1, a2, C_ERROR_1); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| |
| c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); |
| test = runtime_error_ne (c2, b1, C_ERROR_2); |
| *next_code_point = test; |
| next_code_point = &test->next; |
| } |
| break; |
| |
| default: |
| gcc_unreachable (); |
| } |
| } |
| |
| /* Handle the reallocation, if needed. */ |
| |
| if (realloc_c) |
| { |
| gfc_code *lhs_alloc; |
| |
| lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); |
| *next_code_point = lhs_alloc; |
| next_code_point = &lhs_alloc->next; |
| } |
| |
| *next_code_point = call; |
| if_limit->next = co_next; |
| |
| /* Set up the BLAS call. */ |
| |
| call->op = EXEC_CALL; |
| |
| gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true); |
| call->symtree->n.sym->attr.subroutine = 1; |
| call->symtree->n.sym->attr.procedure = 1; |
| call->symtree->n.sym->attr.flavor = FL_PROCEDURE; |
| call->resolved_sym = call->symtree->n.sym; |
| gfc_commit_symbol (call->resolved_sym); |
| |
| /* Argument TRANSA. */ |
| next = gfc_get_actual_arglist (); |
| next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc, |
| transa, 1); |
| |
| call->ext.actual = next; |
| |
| /* Argument TRANSB. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc, |
| transb, 1); |
| actual->next = next; |
| |
| c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1, |
| gfc_integer_4_kind); |
| c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2, |
| gfc_integer_4_kind); |
| |
| b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1, |
| gfc_integer_4_kind); |
| |
| /* Argument M. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = c1; |
| actual->next = next; |
| |
| /* Argument N. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = c2; |
| actual->next = next; |
| |
| /* Argument K. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = b1; |
| actual->next = next; |
| |
| /* Argument ALPHA - set to one. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = gfc_get_constant_expr (type, kind, &co->loc); |
| if (type == BT_REAL) |
| mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE); |
| else |
| mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE); |
| actual->next = next; |
| |
| /* Argument A. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = gfc_copy_expr (matrix_a); |
| actual->next = next; |
| |
| /* Argument LDA. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a), |
| 1, gfc_integer_4_kind); |
| actual->next = next; |
| |
| /* Argument B. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = gfc_copy_expr (matrix_b); |
| actual->next = next; |
| |
| /* Argument LDB. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b), |
| 1, gfc_integer_4_kind); |
| actual->next = next; |
| |
| /* Argument BETA - set to zero. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = gfc_get_constant_expr (type, kind, &co->loc); |
| if (type == BT_REAL) |
| mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE); |
| else |
| mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE); |
| actual->next = next; |
| |
| /* Argument C. */ |
| |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = gfc_copy_expr (expr1); |
| actual->next = next; |
| |
| /* Argument LDC. */ |
| actual = next; |
| next = gfc_get_actual_arglist (); |
| next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1), |
| 1, gfc_integer_4_kind); |
| actual->next = next; |
| |
| return 0; |
| } |
| |
| |
| /* Code for index interchange for loops which are grouped together in DO |
| CONCURRENT or FORALL statements. This is currently only applied if the |
| iterations are grouped together in a single statement. |
| |
| For this transformation, it is assumed that memory access in strides is |
| expensive, and that loops which access later indices (which access memory |
| in bigger strides) should be moved to the first loops. |
| |
| For this, a loop over all the statements is executed, counting the times |
| that the loop iteration values are accessed in each index. The loop |
| indices are then sorted to minimize access to later indices from inner |
| loops. */ |
| |
| /* Type for holding index information. */ |
| |
| typedef struct { |
| gfc_symbol *sym; |
| gfc_forall_iterator *fa; |
| int num; |
| int n[GFC_MAX_DIMENSIONS]; |
| } ind_type; |
| |
| /* Callback function to determine if an expression is the |
| corresponding variable. */ |
| |
| static int |
| has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data) |
| { |
| gfc_expr *expr = *e; |
| gfc_symbol *sym; |
| |
| if (expr->expr_type != EXPR_VARIABLE) |
| return 0; |
| |
| sym = (gfc_symbol *) data; |
| return sym == expr->symtree->n.sym; |
| } |
| |
| /* Callback function to calculate the cost of a certain index. */ |
| |
| static int |
| index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data) |
| { |
| ind_type *ind; |
| gfc_expr *expr; |
| gfc_array_ref *ar; |
| gfc_ref *ref; |
| int i,j; |
| |
| expr = *e; |
| if (expr->expr_type != EXPR_VARIABLE) |
| return 0; |
| |
| ar = NULL; |
| for (ref = expr->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_ARRAY) |
| { |
| ar = &ref->u.ar; |
| break; |
| } |
| } |
| if (ar == NULL || ar->type != AR_ELEMENT) |
| return 0; |
| |
| ind = (ind_type *) data; |
| for (i = 0; i < ar->dimen; i++) |
| { |
| for (j=0; ind[j].sym != NULL; j++) |
| { |
| if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym))) |
| ind[j].n[i]++; |
| } |
| } |
| return 0; |
| } |
| |
| /* Callback function for qsort, to sort the loop indices. */ |
| |
| static int |
| loop_comp (const void *e1, const void *e2) |
| { |
| const ind_type *i1 = (const ind_type *) e1; |
| const ind_type *i2 = (const ind_type *) e2; |
| int i; |
| |
| for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--) |
| { |
| if (i1->n[i] != i2->n[i]) |
| return i1->n[i] - i2->n[i]; |
| } |
| /* All other things being equal, let's not change the ordering. */ |
| return i2->num - i1->num; |
| } |
| |
| /* Main function to do the index interchange. */ |
| |
| static int |
| index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_code *co; |
| co = *c; |
| int n_iter; |
| gfc_forall_iterator *fa; |
| ind_type *ind; |
| int i, j; |
| |
| if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT) |
| return 0; |
| |
| n_iter = 0; |
| for (fa = co->ext.forall_iterator; fa; fa = fa->next) |
| n_iter ++; |
| |
| /* Nothing to reorder. */ |
| if (n_iter < 2) |
| return 0; |
| |
| ind = XALLOCAVEC (ind_type, n_iter + 1); |
| |
| i = 0; |
| for (fa = co->ext.forall_iterator; fa; fa = fa->next) |
| { |
| ind[i].sym = fa->var->symtree->n.sym; |
| ind[i].fa = fa; |
| for (j=0; j<GFC_MAX_DIMENSIONS; j++) |
| ind[i].n[j] = 0; |
| ind[i].num = i; |
| i++; |
| } |
| ind[n_iter].sym = NULL; |
| ind[n_iter].fa = NULL; |
| |
| gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind); |
| qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp); |
| |
| /* Do the actual index interchange. */ |
| co->ext.forall_iterator = fa = ind[0].fa; |
| for (i=1; i<n_iter; i++) |
| { |
| fa->next = ind[i].fa; |
| fa = fa->next; |
| } |
| fa->next = NULL; |
| |
| if (flag_warn_frontend_loop_interchange) |
| { |
| for (i=1; i<n_iter; i++) |
| { |
| if (ind[i-1].num > ind[i].num) |
| { |
| gfc_warning (OPT_Wfrontend_loop_interchange, |
| "Interchanging loops at %L", &co->loc); |
| break; |
| } |
| } |
| } |
| |
| return 0; |
| } |
| |
| #define WALK_SUBEXPR(NODE) \ |
| do \ |
| { \ |
| result = gfc_expr_walker (&(NODE), exprfn, data); \ |
| if (result) \ |
| return result; \ |
| } \ |
| while (0) |
| #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue |
| |
| /* Walk expression *E, calling EXPRFN on each expression in it. */ |
| |
| int |
| gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) |
| { |
| while (*e) |
| { |
| int walk_subtrees = 1; |
| gfc_actual_arglist *a; |
| gfc_ref *r; |
| gfc_constructor *c; |
| |
| int result = exprfn (e, &walk_subtrees, data); |
| if (result) |
| return result; |
| if (walk_subtrees) |
| switch ((*e)->expr_type) |
| { |
| case EXPR_OP: |
| WALK_SUBEXPR ((*e)->value.op.op1); |
| WALK_SUBEXPR_TAIL ((*e)->value.op.op2); |
| break; |
| case EXPR_FUNCTION: |
| for (a = (*e)->value.function.actual; a; a = a->next) |
| WALK_SUBEXPR (a->expr); |
| break; |
| case EXPR_COMPCALL: |
| case EXPR_PPC: |
| WALK_SUBEXPR ((*e)->value.compcall.base_object); |
| for (a = (*e)->value.compcall.actual; a; a = a->next) |
| WALK_SUBEXPR (a->expr); |
| break; |
| |
| case EXPR_STRUCTURE: |
| case EXPR_ARRAY: |
| for (c = gfc_constructor_first ((*e)->value.constructor); c; |
| c = gfc_constructor_next (c)) |
| { |
| if (c->iterator == NULL) |
| WALK_SUBEXPR (c->expr); |
| else |
| { |
| iterator_level ++; |
| WALK_SUBEXPR (c->expr); |
| iterator_level --; |
| WALK_SUBEXPR (c->iterator->var); |
| WALK_SUBEXPR (c->iterator->start); |
| WALK_SUBEXPR (c->iterator->end); |
| WALK_SUBEXPR (c->iterator->step); |
| } |
| } |
| |
| if ((*e)->expr_type != EXPR_ARRAY) |
| break; |
| |
| /* Fall through to the variable case in order to walk the |
| reference. */ |
| gcc_fallthrough (); |
| |
| case EXPR_SUBSTRING: |
| case EXPR_VARIABLE: |
| for (r = (*e)->ref; r; r = r->next) |
| { |
| gfc_array_ref *ar; |
| int i; |
| |
| switch (r->type) |
| { |
| case REF_ARRAY: |
| ar = &r->u.ar; |
| if (ar->type == AR_SECTION || ar->type == AR_ELEMENT) |
| { |
| for (i=0; i< ar->dimen; i++) |
| { |
| WALK_SUBEXPR (ar->start[i]); |
| WALK_SUBEXPR (ar->end[i]); |
| WALK_SUBEXPR (ar->stride[i]); |
| } |
| } |
| |
| break; |
| |
| case REF_SUBSTRING: |
| WALK_SUBEXPR (r->u.ss.start); |
| WALK_SUBEXPR (r->u.ss.end); |
| break; |
| |
| case REF_COMPONENT: |
| case REF_INQUIRY: |
| break; |
| } |
| } |
| |
| default: |
| break; |
| } |
| return 0; |
| } |
| return 0; |
| } |
| |
| #define WALK_SUBCODE(NODE) \ |
| do \ |
| { \ |
| result = gfc_code_walker (&(NODE), codefn, exprfn, data); \ |
| if (result) \ |
| return result; \ |
| } \ |
| while (0) |
| |
| /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN |
| on each expression in it. If any of the hooks returns non-zero, that |
| value is immediately returned. If the hook sets *WALK_SUBTREES to 0, |
| no subcodes or subexpressions are traversed. */ |
| |
| int |
| gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, |
| void *data) |
| { |
| for (; *c; c = &(*c)->next) |
| { |
| int walk_subtrees = 1; |
| int result = codefn (c, &walk_subtrees, data); |
| if (result) |
| return result; |
| |
| if (walk_subtrees) |
| { |
| gfc_code *b; |
| gfc_actual_arglist *a; |
| gfc_code *co; |
| gfc_association_list *alist; |
| bool saved_in_omp_workshare; |
| bool saved_in_omp_atomic; |
| bool saved_in_where; |
| |
| /* There might be statement insertions before the current code, |
| which must not affect the expression walker. */ |
| |
| co = *c; |
| saved_in_omp_workshare = in_omp_workshare; |
| saved_in_omp_atomic = in_omp_atomic; |
| saved_in_where = in_where; |
| |
| switch (co->op) |
| { |
| |
| case EXEC_BLOCK: |
| WALK_SUBCODE (co->ext.block.ns->code); |
| if (co->ext.block.assoc) |
| { |
| bool saved_in_assoc_list = in_assoc_list; |
| |
| in_assoc_list = true; |
| for (alist = co->ext.block.assoc; alist; alist = alist->next) |
| WALK_SUBEXPR (alist->target); |
| |
| in_assoc_list = saved_in_assoc_list; |
| } |
| |
| break; |
| |
| case EXEC_DO: |
| doloop_level ++; |
| WALK_SUBEXPR (co->ext.iterator->var); |
| WALK_SUBEXPR (co->ext.iterator->start); |
| WALK_SUBEXPR (co->ext.iterator->end); |
| WALK_SUBEXPR (co->ext.iterator->step); |
| break; |
| |
| case EXEC_IF: |
| if_level ++; |
| break; |
| |
| case EXEC_WHERE: |
| in_where = true; |
| break; |
| |
| case EXEC_CALL: |
| case EXEC_ASSIGN_CALL: |
| for (a = co->ext.actual; a; a = a->next) |
| WALK_SUBEXPR (a->expr); |
| break; |
| |
| case EXEC_CALL_PPC: |
| WALK_SUBEXPR (co->expr1); |
| for (a = co->ext.actual; a; a = a->next) |
| WALK_SUBEXPR (a->expr); |
| break; |
| |
| case EXEC_SELECT: |
| WALK_SUBEXPR (co->expr1); |
| select_level ++; |
| for (b = co->block; b; b = b->block) |
| { |
| gfc_case *cp; |
| for (cp = b->ext.block.case_list; cp; cp = cp->next) |
| { |
| WALK_SUBEXPR (cp->low); |
| WALK_SUBEXPR (cp->high); |
| } |
| WALK_SUBCODE (b->next); |
| } |
| continue; |
| |
| case EXEC_ALLOCATE: |
| case EXEC_DEALLOCATE: |
| { |
| gfc_alloc *a; |
| for (a = co->ext.alloc.list; a; a = a->next) |
| WALK_SUBEXPR (a->expr); |
| break; |
| } |
| |
| case EXEC_FORALL: |
| case EXEC_DO_CONCURRENT: |
| { |
| gfc_forall_iterator *fa; |
| for (fa = co->ext.forall_iterator; fa; fa = fa->next) |
| { |
| WALK_SUBEXPR (fa->var); |
| WALK_SUBEXPR (fa->start); |
| WALK_SUBEXPR (fa->end); |
| WALK_SUBEXPR (fa->stride); |
| } |
| if (co->op == EXEC_FORALL) |
| forall_level ++; |
| break; |
| } |
| |
| case EXEC_OPEN: |
| WALK_SUBEXPR (co->ext.open->unit); |
| WALK_SUBEXPR (co->ext.open->file); |
| WALK_SUBEXPR (co->ext.open->status); |
| WALK_SUBEXPR (co->ext.open->access); |
| WALK_SUBEXPR (co->ext.open->form); |
| WALK_SUBEXPR (co->ext.open->recl); |
| WALK_SUBEXPR (co->ext.open->blank); |
| WALK_SUBEXPR (co->ext.open->position); |
| WALK_SUBEXPR (co->ext.open->action); |
| WALK_SUBEXPR (co->ext.open->delim); |
| WALK_SUBEXPR (co->ext.open->pad); |
| WALK_SUBEXPR (co->ext.open->iostat); |
| WALK_SUBEXPR (co->ext.open->iomsg); |
| WALK_SUBEXPR (co->ext.open->convert); |
| WALK_SUBEXPR (co->ext.open->decimal); |
| WALK_SUBEXPR (co->ext.open->encoding); |
| WALK_SUBEXPR (co->ext.open->round); |
| WALK_SUBEXPR (co->ext.open->sign); |
| WALK_SUBEXPR (co->ext.open->asynchronous); |
| WALK_SUBEXPR (co->ext.open->id); |
| WALK_SUBEXPR (co->ext.open->newunit); |
| WALK_SUBEXPR (co->ext.open->share); |
| WALK_SUBEXPR (co->ext.open->cc); |
| break; |
| |
| case EXEC_CLOSE: |
| WALK_SUBEXPR (co->ext.close->unit); |
| WALK_SUBEXPR (co->ext.close->status); |
| WALK_SUBEXPR (co->ext.close->iostat); |
| WALK_SUBEXPR (co->ext.close->iomsg); |
| break; |
| |
| case EXEC_BACKSPACE: |
| case EXEC_ENDFILE: |
| case EXEC_REWIND: |
| case EXEC_FLUSH: |
| WALK_SUBEXPR (co->ext.filepos->unit); |
| WALK_SUBEXPR (co->ext.filepos->iostat); |
| WALK_SUBEXPR (co->ext.filepos->iomsg); |
| break; |
| |
| case EXEC_INQUIRE: |
| WALK_SUBEXPR (co->ext.inquire->unit); |
| WALK_SUBEXPR (co->ext.inquire->file); |
| WALK_SUBEXPR (co->ext.inquire->iomsg); |
| WALK_SUBEXPR (co->ext.inquire->iostat); |
| WALK_SUBEXPR (co->ext.inquire->exist); |
| WALK_SUBEXPR (co->ext.inquire->opened); |
| WALK_SUBEXPR (co->ext.inquire->number); |
| WALK_SUBEXPR (co->ext.inquire->named); |
| WALK_SUBEXPR (co->ext.inquire->name); |
| WALK_SUBEXPR (co->ext.inquire->access); |
| WALK_SUBEXPR (co->ext.inquire->sequential); |
| WALK_SUBEXPR (co->ext.inquire->direct); |
| WALK_SUBEXPR (co->ext.inquire->form); |
| WALK_SUBEXPR (co->ext.inquire->formatted); |
| WALK_SUBEXPR (co->ext.inquire->unformatted); |
| WALK_SUBEXPR (co->ext.inquire->recl); |
| WALK_SUBEXPR (co->ext.inquire->nextrec); |
| WALK_SUBEXPR (co->ext.inquire->blank); |
| WALK_SUBEXPR (co->ext.inquire->position); |
| WALK_SUBEXPR (co->ext.inquire->action); |
| WALK_SUBEXPR (co->ext.inquire->read); |
| WALK_SUBEXPR (co->ext.inquire->write); |
| WALK_SUBEXPR (co->ext.inquire->readwrite); |
| WALK_SUBEXPR (co->ext.inquire->delim); |
| WALK_SUBEXPR (co->ext.inquire->encoding); |
| WALK_SUBEXPR (co->ext.inquire->pad); |
| WALK_SUBEXPR (co->ext.inquire->iolength); |
| WALK_SUBEXPR (co->ext.inquire->convert); |
| WALK_SUBEXPR (co->ext.inquire->strm_pos); |
| WALK_SUBEXPR (co->ext.inquire->asynchronous); |
| WALK_SUBEXPR (co->ext.inquire->decimal); |
| WALK_SUBEXPR (co->ext.inquire->pending); |
| WALK_SUBEXPR (co->ext.inquire->id); |
| WALK_SUBEXPR (co->ext.inquire->sign); |
| WALK_SUBEXPR (co->ext.inquire->size); |
| WALK_SUBEXPR (co->ext.inquire->round); |
| break; |
| |
| case EXEC_WAIT: |
| WALK_SUBEXPR (co->ext.wait->unit); |
| WALK_SUBEXPR (co->ext.wait->iostat); |
| WALK_SUBEXPR (co->ext.wait->iomsg); |
| WALK_SUBEXPR (co->ext.wait->id); |
| break; |
| |
| case EXEC_READ: |
| case EXEC_WRITE: |
| WALK_SUBEXPR (co->ext.dt->io_unit); |
| WALK_SUBEXPR (co->ext.dt->format_expr); |
| WALK_SUBEXPR (co->ext.dt->rec); |
| WALK_SUBEXPR (co->ext.dt->advance); |
| WALK_SUBEXPR (co->ext.dt->iostat); |
| WALK_SUBEXPR (co->ext.dt->size); |
| WALK_SUBEXPR (co->ext.dt->iomsg); |
| WALK_SUBEXPR (co->ext.dt->id); |
| WALK_SUBEXPR (co->ext.dt->pos); |
| WALK_SUBEXPR (co->ext.dt->asynchronous); |
| WALK_SUBEXPR (co->ext.dt->blank); |
| WALK_SUBEXPR (co->ext.dt->decimal); |
| WALK_SUBEXPR (co->ext.dt->delim); |
| WALK_SUBEXPR (co->ext.dt->pad); |
| WALK_SUBEXPR (co->ext.dt->round); |
| WALK_SUBEXPR (co->ext.dt->sign); |
| WALK_SUBEXPR (co->ext.dt->extra_comma); |
| break; |
| |
| case EXEC_OACC_ATOMIC: |
| case EXEC_OMP_ATOMIC: |
| in_omp_atomic = true; |
| break; |
| |
| case EXEC_OMP_PARALLEL: |
| case EXEC_OMP_PARALLEL_DO: |
| case EXEC_OMP_PARALLEL_DO_SIMD: |
| case EXEC_OMP_PARALLEL_LOOP: |
| case EXEC_OMP_PARALLEL_MASKED: |
| case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: |
| case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: |
| case EXEC_OMP_PARALLEL_MASTER: |
| case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: |
| case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: |
| case EXEC_OMP_PARALLEL_SECTIONS: |
| |
| in_omp_workshare = false; |
| |
| /* This goto serves as a shortcut to avoid code |
| duplication or a larger if or switch statement. */ |
| goto check_omp_clauses; |
| |
| case EXEC_OMP_WORKSHARE: |
| case EXEC_OMP_PARALLEL_WORKSHARE: |
| |
| in_omp_workshare = true; |
| |
| /* Fall through */ |
| |
| case EXEC_OMP_CRITICAL: |
| case EXEC_OMP_DISTRIBUTE: |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_DISTRIBUTE_SIMD: |
| case EXEC_OMP_DO: |
| case EXEC_OMP_DO_SIMD: |
| case EXEC_OMP_LOOP: |
| case EXEC_OMP_ORDERED: |
| case EXEC_OMP_SECTIONS: |
| case EXEC_OMP_SINGLE: |
| case EXEC_OMP_END_SINGLE: |
| case EXEC_OMP_SIMD: |
| case EXEC_OMP_TASKLOOP: |
| case EXEC_OMP_TASKLOOP_SIMD: |
| case EXEC_OMP_TARGET: |
| case EXEC_OMP_TARGET_DATA: |
| case EXEC_OMP_TARGET_ENTER_DATA: |
| case EXEC_OMP_TARGET_EXIT_DATA: |
| case EXEC_OMP_TARGET_PARALLEL: |
| case EXEC_OMP_TARGET_PARALLEL_DO: |
| case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_PARALLEL_LOOP: |
| case EXEC_OMP_TARGET_SIMD: |
| case EXEC_OMP_TARGET_TEAMS: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
| case EXEC_OMP_TARGET_TEAMS_LOOP: |
| case EXEC_OMP_TARGET_UPDATE: |
| case EXEC_OMP_TASK: |
| case EXEC_OMP_TEAMS: |
| case EXEC_OMP_TEAMS_DISTRIBUTE: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
| case EXEC_OMP_TEAMS_LOOP: |
| |
| /* Come to this label only from the |
| EXEC_OMP_PARALLEL_* cases above. */ |
| |
| check_omp_clauses: |
| |
| if (co->ext.omp_clauses) |
| { |
| gfc_omp_namelist *n; |
| static int list_types[] |
| = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND, |
| OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM }; |
| size_t idx; |
| WALK_SUBEXPR (co->ext.omp_clauses->if_expr); |
| WALK_SUBEXPR (co->ext.omp_clauses->final_expr); |
| WALK_SUBEXPR (co->ext.omp_clauses->num_threads); |
| WALK_SUBEXPR (co->ext.omp_clauses->chunk_size); |
| WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr); |
| WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr); |
| WALK_SUBEXPR (co->ext.omp_clauses->num_teams); |
| WALK_SUBEXPR (co->ext.omp_clauses->device); |
| WALK_SUBEXPR (co->ext.omp_clauses->thread_limit); |
| WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size); |
| WALK_SUBEXPR (co->ext.omp_clauses->grainsize); |
| WALK_SUBEXPR (co->ext.omp_clauses->hint); |
| WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); |
| WALK_SUBEXPR (co->ext.omp_clauses->priority); |
| WALK_SUBEXPR (co->ext.omp_clauses->detach); |
| for (idx = 0; idx < OMP_IF_LAST; idx++) |
| WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]); |
| for (idx = 0; |
| idx < sizeof (list_types) / sizeof (list_types[0]); |
| idx++) |
| for (n = co->ext.omp_clauses->lists[list_types[idx]]; |
| n; n = n->next) |
| WALK_SUBEXPR (n->expr); |
| } |
| break; |
| default: |
| break; |
| } |
| |
| WALK_SUBEXPR (co->expr1); |
| WALK_SUBEXPR (co->expr2); |
| WALK_SUBEXPR (co->expr3); |
| WALK_SUBEXPR (co->expr4); |
| for (b = co->block; b; b = b->block) |
| { |
| WALK_SUBEXPR (b->expr1); |
| WALK_SUBEXPR (b->expr2); |
| WALK_SUBCODE (b->next); |
| } |
| |
| if (co->op == EXEC_FORALL) |
| forall_level --; |
| |
| if (co->op == EXEC_DO) |
| doloop_level --; |
| |
| if (co->op == EXEC_IF) |
| if_level --; |
| |
| if (co->op == EXEC_SELECT) |
| select_level --; |
| |
| in_omp_workshare = saved_in_omp_workshare; |
| in_omp_atomic = saved_in_omp_atomic; |
| in_where = saved_in_where; |
| } |
| } |
| return 0; |
| } |
| |
| /* As a post-resolution step, check that all global symbols which are |
| not declared in the source file match in their call signatures. |
| We do this by looping over the code (and expressions). The first call |
| we happen to find is assumed to be canonical. */ |
| |
| |
| /* Common tests for argument checking for both functions and subroutines. */ |
| |
| static int |
| check_externals_procedure (gfc_symbol *sym, locus *loc, |
| gfc_actual_arglist *actual) |
| { |
| gfc_gsymbol *gsym; |
| gfc_symbol *def_sym = NULL; |
| |
| if (sym == NULL || sym->attr.is_bind_c) |
| return 0; |
| |
| if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) |
| return 0; |
| |
| if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL) |
| return 0; |
| |
| gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); |
| if (gsym == NULL) |
| return 0; |
| |
| if (gsym->ns) |
| gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); |
| |
| if (def_sym) |
| { |
| gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc); |
| return 0; |
| } |
| |
| /* First time we have seen this procedure called. Let's create an |
| "interface" from the call and put it into a new namespace. */ |
| gfc_namespace *save_ns; |
| gfc_symbol *new_sym; |
| |
| gsym->where = *loc; |
| save_ns = gfc_current_ns; |
| gsym->ns = gfc_get_namespace (gfc_current_ns, 0); |
| gsym->ns->proc_name = sym; |
| |
| gfc_get_symbol (sym->name, gsym->ns, &new_sym); |
| gcc_assert (new_sym); |
| new_sym->attr = sym->attr; |
| new_sym->attr.if_source = IFSRC_DECL; |
| gfc_current_ns = gsym->ns; |
| |
| gfc_get_formal_from_actual_arglist (new_sym, actual); |
| new_sym->declared_at = *loc; |
| gfc_current_ns = save_ns; |
| |
| return 0; |
| |
| } |
| |
| /* Callback for calls of external routines. */ |
| |
| static int |
| check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_code *co = *c; |
| gfc_symbol *sym; |
| locus *loc; |
| gfc_actual_arglist *actual; |
| |
| if (co->op != EXEC_CALL) |
| return 0; |
| |
| sym = co->resolved_sym; |
| loc = &co->loc; |
| actual = co->ext.actual; |
| |
| return check_externals_procedure (sym, loc, actual); |
| |
| } |
| |
| /* Callback for external functions. */ |
| |
| static int |
| check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data ATTRIBUTE_UNUSED) |
| { |
| gfc_expr *e = *ep; |
| gfc_symbol *sym; |
| locus *loc; |
| gfc_actual_arglist *actual; |
| |
| if (e->expr_type != EXPR_FUNCTION) |
| return 0; |
| |
| sym = e->value.function.esym; |
| if (sym == NULL) |
| return 0; |
| |
| loc = &e->where; |
| actual = e->value.function.actual; |
| |
| return check_externals_procedure (sym, loc, actual); |
| } |
| |
| /* Function to check if any interface clashes with a global |
| identifier, to be invoked via gfc_traverse_ns. */ |
| |
| static void |
| check_against_globals (gfc_symbol *sym) |
| { |
| gfc_gsymbol *gsym; |
| gfc_symbol *def_sym = NULL; |
| const char *sym_name; |
| char buf [200]; |
| |
| if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE |
| || sym->attr.generic || sym->error) |
| return; |
| |
| if (sym->binding_label) |
| sym_name = sym->binding_label; |
| else |
| sym_name = sym->name; |
| |
| gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name); |
| if (gsym && gsym->ns) |
| gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); |
| |
| if (!def_sym || def_sym->error || def_sym->attr.generic) |
| return; |
| |
| buf[0] = 0; |
| gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf), |
| NULL, NULL, NULL); |
| if (buf[0] != 0) |
| { |
| gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at, |
| &sym->declared_at); |
| sym->error = 1; |
| def_sym->error = 1; |
| } |
| |
| } |
| |
| /* Do the code-walkling part for gfc_check_externals. */ |
| |
| static void |
| gfc_check_externals0 (gfc_namespace *ns) |
| { |
| gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL); |
| |
| for (ns = ns->contained; ns; ns = ns->sibling) |
| { |
| if (ns->code == NULL || ns->code->op != EXEC_BLOCK) |
| gfc_check_externals0 (ns); |
| } |
| |
| } |
| |
| /* Called routine. */ |
| |
| void |
| gfc_check_externals (gfc_namespace *ns) |
| { |
| gfc_clear_error (); |
| |
| /* Turn errors into warnings if the user indicated this. */ |
| |
| if (!pedantic && flag_allow_argument_mismatch) |
| gfc_errors_to_warnings (true); |
| |
| gfc_check_externals0 (ns); |
| gfc_traverse_ns (ns, check_against_globals); |
| |
| gfc_errors_to_warnings (false); |
| } |
| |
| /* Callback function. If there is a call to a subroutine which is |
| neither pure nor implicit_pure, unset the implicit_pure flag for |
| the caller and return -1. */ |
| |
| static int |
| implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *sym_data) |
| { |
| gfc_code *co = *c; |
| gfc_symbol *caller_sym; |
| symbol_attribute *a; |
| |
| if (co->op != EXEC_CALL || co->resolved_sym == NULL) |
| return 0; |
| |
| a = &co->resolved_sym->attr; |
| if (a->intrinsic || a->pure || a->implicit_pure) |
| return 0; |
| |
| caller_sym = (gfc_symbol *) sym_data; |
| gfc_unset_implicit_pure (caller_sym); |
| return 1; |
| } |
| |
| /* Callback function. If there is a call to a function which is |
| neither pure nor implicit_pure, unset the implicit_pure flag for |
| the caller and return 1. */ |
| |
| static int |
| implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data) |
| { |
| gfc_expr *expr = *e; |
| gfc_symbol *caller_sym; |
| gfc_symbol *sym; |
| symbol_attribute *a; |
| |
| if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym) |
| return 0; |
| |
| sym = expr->symtree->n.sym; |
| a = &sym->attr; |
| if (a->pure || a->implicit_pure) |
| return 0; |
| |
| caller_sym = (gfc_symbol *) sym_data; |
| gfc_unset_implicit_pure (caller_sym); |
| return 1; |
| } |
| |
| /* Go through all procedures in the namespace and unset the |
| implicit_pure attribute for any procedure that calls something not |
| pure or implicit pure. */ |
| |
| bool |
| gfc_fix_implicit_pure (gfc_namespace *ns) |
| { |
| bool changed = false; |
| gfc_symbol *proc = ns->proc_name; |
| |
| if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure |
| && ns->code |
| && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr, |
| (void *) ns->proc_name)) |
| changed = true; |
| |
| for (ns = ns->contained; ns; ns = ns->sibling) |
| { |
| if (gfc_fix_implicit_pure (ns)) |
| changed = true; |
| } |
| |
| return changed; |
| } |