From 3055d879edb1bc2a3923f92a5e681c8f6774fbc3 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Sun, 19 Jul 2020 12:23:43 +0200 Subject: [PATCH] Fix handling of implicit_pure by checking if non-pure procedures are called. Procedures are marked as implicit_pure if they fulfill the criteria of pure procedures. In this case, a procedure was not marked as not being implicit_pure which called another procedure, which had not yet been marked as not being implicit_impure. Fixed by iterating over all procedures, setting callers of procedures which are non-pure and non-implicit_pure as non-implicit_pure and doing this until no more procedure has been changed. gcc/fortran/ChangeLog: 2020-07-19 Thomas Koenig PR fortran/96018 * frontend-passes.c (gfc_check_externals): Adjust formatting. (implicit_pure_call): New function. (implicit_pure_expr): New function. (gfc_fix_implicit_pure): New function. * gfortran.h (gfc_fix_implicit_pure): New prototype. * parse.c (translate_all_program_units): Call gfc_fix_implicit_pure. --- gcc/fortran/frontend-passes.c | 76 ++++++++++++++++++- gcc/fortran/gfortran.h | 1 + gcc/fortran/parse.c | 22 ++++++ gcc/testsuite/gfortran.dg/implicit_pure_5.c | 7 ++ gcc/testsuite/gfortran.dg/implicit_pure_5.f90 | 63 +++++++++++++++ 5 files changed, 168 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/implicit_pure_5.c create mode 100644 gcc/testsuite/gfortran.dg/implicit_pure_5.f90 diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 7768fdc25ca..cdeed8943b0 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -5551,7 +5551,8 @@ gfc_check_externals0 (gfc_namespace *ns) /* Called routine. */ -void gfc_check_externals (gfc_namespace *ns) +void +gfc_check_externals (gfc_namespace *ns) { gfc_clear_error (); @@ -5566,3 +5567,76 @@ void gfc_check_externals (gfc_namespace *ns) 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; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 24c5101c4cb..264822ef9f8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3623,6 +3623,7 @@ int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *); int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *); bool gfc_has_dimen_vector_ref (gfc_expr *e); void gfc_check_externals (gfc_namespace *); +bool gfc_fix_implicit_pure (gfc_namespace *); /* simplify.c */ diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 36715134a2c..d30208febb1 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -6447,6 +6447,11 @@ loop: gfc_resolve (gfc_current_ns); + /* Fix the implicit_pure attribute for those procedures who should + not have it. */ + while (gfc_fix_implicit_pure (gfc_current_ns)) + ; + /* Dump the parse tree if requested. */ if (flag_dump_fortran_original) gfc_dump_parse_tree (gfc_current_ns, stdout); @@ -6492,6 +6497,23 @@ done: /* Do the resolution. */ resolve_all_program_units (gfc_global_ns_list); + /* Go through all top-level namespaces and unset the implicit_pure + attribute for any procedures that call something not pure or + implicit_pure. Because the a procedure marked as not implicit_pure + in one sweep may be called by another routine, we repeat this + process until there are no more changes. */ + bool changed; + do + { + changed = false; + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + { + if (gfc_fix_implicit_pure (gfc_current_ns)) + changed = true; + } + } + while (changed); /* Fixup for external procedures. */ for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; diff --git a/gcc/testsuite/gfortran.dg/implicit_pure_5.c b/gcc/testsuite/gfortran.dg/implicit_pure_5.c new file mode 100644 index 00000000000..67a6d9ca45e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implicit_pure_5.c @@ -0,0 +1,7 @@ +#include + +extern int num_calls; +int side_effect_c() +{ + num_calls ++; +} diff --git a/gcc/testsuite/gfortran.dg/implicit_pure_5.f90 b/gcc/testsuite/gfortran.dg/implicit_pure_5.f90 new file mode 100644 index 00000000000..7f1c887e3f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implicit_pure_5.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-additional-sources implicit_pure_5.c } +! PR fortran/96018 - a wrongly marked implicit_pure +! function caused wrong code. +module wrapper + use, intrinsic :: iso_c_binding, only : c_int + implicit none + integer(kind=c_int), bind(C) :: num_calls +contains + + integer function call_side_effect() result(ierr) + call side_effect(ierr) + end function call_side_effect + + integer function inner_3d(array) result(ierr) + real, intent(in) :: array(:,:,:) + integer dimensions(3) + dimensions = shape(array) + ierr = call_side_effect() + end function inner_3d + + integer function inner_4d(array) result(ierr) + real, intent(in) :: array(:,:,:,:) + integer dimensions(4) + dimensions = shape(array) + ierr = call_side_effect() + end function inner_4d + + subroutine write_3d() + real :: array(1,1,1) + integer ierr + ierr = inner_3d(array) + ierr = call_side_effect() + end subroutine write_3d + + subroutine write_4d() + real array(1,1,1,1) + integer ierr + ierr = inner_4d(array) + ierr = call_side_effect() + end subroutine write_4d + + subroutine side_effect(ierr) + integer, intent(out) :: ierr ! Error code + interface + integer(c_int) function side_effect_c() bind(C,name='side_effect_c') + use, intrinsic :: iso_c_binding, only: c_int + end function side_effect_c + end interface + ierr = side_effect_c() + end subroutine side_effect + +end module wrapper + +program self_contained + use wrapper + implicit none + call write_3d() + if (num_calls /= 2) stop 1 + call write_4d() + if (num_calls /= 4) stop 2 +end program self_contained + -- 2.30.2