diff options
| author | Paul Thomas <pault@gcc.gnu.org> | 2007-10-29 14:13:44 +0000 |
|---|---|---|
| committer | Tobias Burnus <burnus@gcc.gnu.org> | 2007-10-29 15:13:44 +0100 |
| commit | 640670c7f4ec13d4ef3aab73f7b7ea7eb05b7a9d (patch) | |
| tree | 965c87505ca071b2707c92dabd1c972a1673e22b /gcc/fortran/trans-stmt.c | |
| parent | a270181e4059512728c286f6aff14219354cf0cf (diff) | |
| download | gcc-640670c7f4ec13d4ef3aab73f7b7ea7eb05b7a9d.zip gcc-640670c7f4ec13d4ef3aab73f7b7ea7eb05b7a9d.tar.gz gcc-640670c7f4ec13d4ef3aab73f7b7ea7eb05b7a9d.tar.bz2 | |
[multiple changes]
2007-10-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31217
PR fortran/33811
PR fortran/33686
* trans-array.c (gfc_conv_loop_setup): Send a complete type to
gfc_trans_create_temp_array if the temporary is character.
* trans-stmt.c (gfc_trans_assign_need_temp): Do likewise for
allocate_temp_for_forall_nest.
(forall_replace): New function.
(forall_replace_symtree): New function.
(forall_restore): New function.
(forall_restore_symtree): New function.
(forall_make_variable_temp): New function.
(check_forall_dependencies): New function.
(cleanup_forall_symtrees): New function.
gfc_trans_forall_1): Add and initialize pre and post blocks.
Call check_forall_dependencies to check for all dependencies
and either trigger second forall block to copy temporary or
copy lval, outside the forall construct and replace all
dependent references. After assignment clean-up and coalesce
the blocks at the end of the function.
* gfortran.h : Add prototypes for gfc_traverse_expr and
find_forall_index.
expr.c (gfc_traverse_expr): New function to traverse expression
and visit all subexpressions, under control of a logical flag,
a symbol and an integer pointer. The slave function is caller
defined and is only called on EXPR_VARIABLE.
(expr_set_symbols_referenced): Called by above to set symbols
referenced.
(gfc_expr_set_symbols_referenced): Rework of this function to
use two new functions above.
* resolve.c (find_forall_index): Rework with gfc_traverse_expr,
using forall_index.
(forall_index): New function used by previous.
* dependency.c (gfc_check_dependency): Use gfc_dep_resolver for
all references, not just REF_ARRAY.
(gfc_dep_resolver): Correct the logic for substrings so that
overlapping arrays are handled correctly.
2007-10-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31217
PR fortran/33811
* gfortran.dg/forall_12.f90: New test.
PR fortran/33686
* gfortran.dg/forall_13.f90: New test.
From-SVN: r129720
Diffstat (limited to 'gcc/fortran/trans-stmt.c')
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 237 |
1 files changed, 232 insertions, 5 deletions
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 0bf0387..cbb15a5 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1510,6 +1510,205 @@ gfc_trans_select (gfc_code * code) } +/* Traversal function to substitute a replacement symtree if the symbol + in the expression is the same as that passed. f == 2 signals that + that variable itself is not to be checked - only the references. + This group of functions is used when the variable expression in a + FORALL assignment has internal references. For example: + FORALL (i = 1:4) p(p(i)) = i + The only recourse here is to store a copy of 'p' for the index + expression. */ + +static gfc_symtree *new_symtree; +static gfc_symtree *old_symtree; + +static bool +forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f) +{ + gcc_assert (expr->expr_type == EXPR_VARIABLE); + + if (*f == 2) + *f = 1; + else if (expr->symtree->n.sym == sym) + expr->symtree = new_symtree; + + return false; +} + +static void +forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f) +{ + gfc_traverse_expr (e, sym, forall_replace, f); +} + +static bool +forall_restore (gfc_expr *expr, + gfc_symbol *sym ATTRIBUTE_UNUSED, + int *f ATTRIBUTE_UNUSED) +{ + gcc_assert (expr->expr_type == EXPR_VARIABLE); + + if (expr->symtree == new_symtree) + expr->symtree = old_symtree; + + return false; +} + +static void +forall_restore_symtree (gfc_expr *e) +{ + gfc_traverse_expr (e, NULL, forall_restore, 0); +} + +static void +forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) +{ + gfc_se tse; + gfc_se rse; + gfc_expr *e; + gfc_symbol *new_sym; + gfc_symbol *old_sym; + gfc_symtree *root; + tree tmp; + + /* Build a copy of the lvalue. */ + old_symtree = c->expr->symtree; + old_sym = old_symtree->n.sym; + e = gfc_lval_expr_from_sym (old_sym); + if (old_sym->attr.dimension) + { + gfc_init_se (&tse, NULL); + gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN); + gfc_add_block_to_block (pre, &tse.pre); + gfc_add_block_to_block (post, &tse.post); + tse.expr = build_fold_indirect_ref (tse.expr); + + if (e->ts.type != BT_CHARACTER) + { + /* Use the variable offset for the temporary. */ + tmp = gfc_conv_descriptor_offset (tse.expr); + gfc_add_modify_expr (pre, tmp, + gfc_conv_array_offset (old_sym->backend_decl)); + } + } + else + { + gfc_init_se (&tse, NULL); + gfc_init_se (&rse, NULL); + gfc_conv_expr (&rse, e); + if (e->ts.type == BT_CHARACTER) + { + tse.string_length = rse.string_length; + tmp = gfc_get_character_type_len (gfc_default_character_kind, + tse.string_length); + tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp), + rse.string_length); + gfc_add_block_to_block (pre, &tse.pre); + gfc_add_block_to_block (post, &tse.post); + } + else + { + tmp = gfc_typenode_for_spec (&e->ts); + tse.expr = gfc_create_var (tmp, "temp"); + } + + tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true, + e->expr_type == EXPR_VARIABLE); + gfc_add_expr_to_block (pre, tmp); + } + gfc_free_expr (e); + + /* Create a new symbol to represent the lvalue. */ + new_sym = gfc_new_symbol (old_sym->name, NULL); + new_sym->ts = old_sym->ts; + new_sym->attr.referenced = 1; + new_sym->attr.dimension = old_sym->attr.dimension; + new_sym->attr.flavor = old_sym->attr.flavor; + + /* Use the temporary as the backend_decl. */ + new_sym->backend_decl = tse.expr; + + /* Create a fake symtree for it. */ + root = NULL; + new_symtree = gfc_new_symtree (&root, old_sym->name); + new_symtree->n.sym = new_sym; + gcc_assert (new_symtree == root); + + /* Go through the expression reference replacing the old_symtree + with the new. */ + forall_replace_symtree (c->expr, old_sym, 2); + + /* Now we have made this temporary, we might as well use it for + the right hand side. */ + forall_replace_symtree (c->expr2, old_sym, 1); +} + + +/* Handles dependencies in forall assignments. */ +static int +check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) +{ + gfc_ref *lref; + gfc_ref *rref; + int need_temp; + gfc_symbol *lsym; + + lsym = c->expr->symtree->n.sym; + need_temp = gfc_check_dependency (c->expr, c->expr2, 0); + + /* Now check for dependencies within the 'variable' + expression itself. These are treated by making a complete + copy of variable and changing all the references to it + point to the copy instead. Note that the shallow copy of + the variable will not suffice for derived types with + pointer components. We therefore leave these to their + own devices. */ + if (lsym->ts.type == BT_DERIVED + && lsym->ts.derived->attr.pointer_comp) + return need_temp; + + new_symtree = NULL; + if (find_forall_index (c->expr, lsym, 2) == SUCCESS) + { + forall_make_variable_temp (c, pre, post); + need_temp = 0; + } + + /* Substrings with dependencies are treated in the same + way. */ + if (c->expr->ts.type == BT_CHARACTER + && c->expr->ref + && c->expr2->expr_type == EXPR_VARIABLE + && lsym == c->expr2->symtree->n.sym) + { + for (lref = c->expr->ref; lref; lref = lref->next) + if (lref->type == REF_SUBSTRING) + break; + for (rref = c->expr2->ref; rref; rref = rref->next) + if (rref->type == REF_SUBSTRING) + break; + + if (rref && lref + && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0) + { + forall_make_variable_temp (c, pre, post); + need_temp = 0; + } + } + return need_temp; +} + + +static void +cleanup_forall_symtrees (gfc_code *c) +{ + forall_restore_symtree (c->expr); + forall_restore_symtree (c->expr2); + gfc_free (new_symtree->n.sym); + gfc_free (new_symtree); +} + + /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY is the contents of the FORALL block/stmt to be iterated. MASK_FLAG indicates whether we should generate code to test the FORALLs mask @@ -2172,7 +2371,20 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, &lss, &rss); /* The type of LHS. Used in function allocate_temp_for_forall_nest */ - type = gfc_typenode_for_spec (&expr1->ts); + if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length) + { + if (!expr1->ts.cl->backend_decl) + { + gfc_se tse; + gfc_init_se (&tse, NULL); + gfc_conv_expr (&tse, expr1->ts.cl->length); + expr1->ts.cl->backend_decl = tse.expr; + } + type = gfc_get_character_type_len (gfc_default_character_kind, + expr1->ts.cl->backend_decl); + } + else + type = gfc_typenode_for_spec (&expr1->ts); /* Allocate temporary for nested forall construct according to the information in nested_forall_info and inner_size. */ @@ -2412,6 +2624,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, static tree gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) { + stmtblock_t pre; + stmtblock_t post; stmtblock_t block; stmtblock_t body; tree *var; @@ -2459,7 +2673,9 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) /* Allocate the space for info. */ info = (forall_info *) gfc_getmem (sizeof (forall_info)); - gfc_start_block (&block); + gfc_start_block (&pre); + gfc_init_block (&post); + gfc_init_block (&block); n = 0; for (fa = code->ext.forall_iterator; fa; fa = fa->next) @@ -2619,8 +2835,11 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) switch (c->op) { case EXEC_ASSIGN: - /* A scalar or array assignment. */ - need_temp = gfc_check_dependency (c->expr, c->expr2, 0); + /* A scalar or array assignment. DO the simple check for + lhs to rhs dependencies. These make a temporary for the + rhs and form a second forall block to copy to variable. */ + need_temp = check_forall_dependencies(c, &pre, &post); + /* Temporaries due to array assignment data dependencies introduce no end of problems. */ if (need_temp) @@ -2637,6 +2856,11 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) gfc_add_expr_to_block (&block, tmp); } + /* Cleanup any temporary symtrees that have been made to deal + with dependencies. */ + if (new_symtree) + cleanup_forall_symtrees (c); + break; case EXEC_WHERE: @@ -2706,7 +2930,10 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) if (maskindex) pushdecl (maskindex); - return gfc_finish_block (&block); + gfc_add_block_to_block (&pre, &block); + gfc_add_block_to_block (&pre, &post); + + return gfc_finish_block (&pre); } |