Patchwork [Fortran] PR 54884 - Fix TREE_PUBLIC() issue with PRIVATE module procedures

login
register
mail settings
Submitter Tobias Burnus
Date Dec. 21, 2012, 5:30 p.m.
Message ID <50D49CB4.6090306@net-b.de>
Download mbox | patch
Permalink /patch/207863/
State New
Headers show

Comments

Tobias Burnus - Dec. 21, 2012, 5:30 p.m.
General background: Private module variables and module procedures can 
be marked as TREE_PUBLIC()= 0, unless they are used in the specification 
expression of the dummy argument or result variable of public module 
procedures (or private module procedures in public generic interfaces).

That gives a lot of optimization possibilities. However, it is not 
trivial to get it right. The current version has resolve_function:

3128      if (sym && specification_expr && sym->attr.function
3129          && gfc_current_ns->proc_name
3130          && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
3131        sym->attr.public_used = 1;


That fails if one does not operate on a result variable but on a dummy 
argument, which might be not at ns->proc_name but at ns->parent->proc_name.

The attached patch tried to fix the 4.8 regression without breaking the 
existing test cases.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

PS: I start to understand why other compilers don't do it.

Patch

2012-12-21  Tobias Burnus  <burnus@net-b.de>

	PR fortran/54884
	* resolve.c (spec_expr_mod_proc): New static variable.
	(resolve_formal_arglist, resolve_function, resolve_variable,
	resolve_charlen, resolve_fl_variable, resolve_symbol): Use
	it to decide when to mark a symbol as public_use.

2012-12-21  Tobias Burnus  <burnus@net-b.de>

	PR fortran/54884
	* gfortran.dg/public_private_module_8.f90: New.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fce6f73..95cc4de 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -83,6 +83,10 @@  static int formal_arg_flag = 0;
 /* True if we are resolving a specification expression.  */
 static bool specification_expr = false;
 
+/* True if we are resolving the specification expression of a module
+   procedure's result or dummy variable; used for the public_use setting.  */
+static bool spec_expr_mod_proc = false;
+
 /* The id of the last entry seen.  */
 static int current_entry_id;
 
@@ -278,7 +282,7 @@  resolve_formal_arglist (gfc_symbol *proc)
 {
   gfc_formal_arglist *f;
   gfc_symbol *sym;
-  bool saved_specification_expr;
+  bool saved_specification_expr, saved_spec_expr_mod_proc;
   int i;
 
   if (proc->result != NULL)
@@ -339,8 +343,19 @@  resolve_formal_arglist (gfc_symbol *proc)
 
       saved_specification_expr = specification_expr;
       specification_expr = true;
+      saved_spec_expr_mod_proc = spec_expr_mod_proc;
+      if ((sym->attr.dummy || sym->attr.result || sym->attr.function)
+	  && ((sym == sym->result && sym->ns->proc_name
+	       && sym->ns->proc_name->attr.flavor == FL_MODULE)
+	      || (sym != sym->result && sym->ns->parent
+		  && sym->ns->parent->proc_name
+		  && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)))
+	spec_expr_mod_proc = true;
+
       gfc_resolve_array_spec (as, 0);
+
       specification_expr = saved_specification_expr;
+      spec_expr_mod_proc = saved_spec_expr_mod_proc;
 
       /* We can't tell if an array with dimension (:) is assumed or deferred
 	 shape until we know if it has the pointer or allocatable attributes.
@@ -3129,12 +3144,13 @@  resolve_function (gfc_expr *expr)
       return FAILURE;
     }
 
-  if (sym && specification_expr && sym->attr.function
-      && gfc_current_ns->proc_name
-      && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+  if (sym && spec_expr_mod_proc && sym->attr.function
+      && ((gfc_current_ns->proc_name
+	   && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+	  || (gfc_current_ns->parent && gfc_current_ns->parent->proc_name
+	      && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE)))
     sym->attr.public_used = 1;
 
-
   /* Switch off assumed size checking and do this again for certain kinds
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
@@ -5363,14 +5379,15 @@  resolve_variable (gfc_expr *e)
   /* If a PRIVATE variable is used in the specification expression of the
      result variable, it might be accessed from outside the module and can
      thus not be TREE_PUBLIC() = 0.
-     TODO: sym->attr.public_used only has to be set for the result variable's
-     type-parameter expression and not for dummies or automatic variables.
-     Additionally, it only has to be set if the function is either PUBLIC or
-     used in a generic interface or TBP; unfortunately,
+     TODO: sym->attr.public_used only has to be set if the function is
+     either PUBLIC or used in a generic interface or TBP; unfortunately,
      proc_name->attr.public_used can get set at a later stage.  */
-  if (specification_expr && sym->attr.access == ACCESS_PRIVATE
+  if (spec_expr_mod_proc
       && !sym->attr.function && !sym->attr.use_assoc
-      && gfc_current_ns->proc_name && gfc_current_ns->proc_name->attr.function)
+      && ((gfc_current_ns->proc_name
+	   && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+	  || (gfc_current_ns->parent && gfc_current_ns->parent->proc_name
+	      && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE)))
     sym->attr.public_used = 1;
 
   /* Deal with forward references to entries during resolve_code, to
@@ -5384,7 +5401,7 @@  resolve_variable (gfc_expr *e)
       gfc_entry_list *entry;
       gfc_formal_arglist *formal;
       int n;
-      bool seen, saved_specification_expr;
+      bool seen, saved_specification_expr, saved_spec_expr_mod_proc;
 
       /* If the symbol is a dummy...  */
       if (sym->attr.dummy && sym->ns == gfc_current_ns)
@@ -5419,6 +5436,15 @@  resolve_variable (gfc_expr *e)
       /* Now do the same check on the specification expressions.  */
       saved_specification_expr = specification_expr;
       specification_expr = true;
+      saved_spec_expr_mod_proc = spec_expr_mod_proc;
+      if ((sym->attr.dummy || sym->attr.result || sym->attr.function)
+	  && ((sym == sym->result && sym->ns->proc_name
+	       && sym->ns->proc_name->attr.flavor == FL_MODULE)
+	      || (sym != sym->result && sym->ns->parent
+		  && sym->ns->parent->proc_name
+		  && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)))
+	spec_expr_mod_proc = true;
+
       if (sym->ts.type == BT_CHARACTER
 	  && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
 	t = FAILURE;
@@ -5432,6 +5458,7 @@  resolve_variable (gfc_expr *e)
 	       t = FAILURE;
 	  }
       specification_expr = saved_specification_expr;
+      spec_expr_mod_proc = saved_spec_expr_mod_proc;
 
       if (t == SUCCESS)
 	/* Update the symbol's entry level.  */
@@ -10674,7 +10701,7 @@  static gfc_try
 resolve_charlen (gfc_charlen *cl)
 {
   int i, k;
-  bool saved_specification_expr;
+  bool saved_specification_expr, saved_spec_expr_mod_proc;
 
   if (cl->resolved)
     return SUCCESS;
@@ -10682,18 +10709,26 @@  resolve_charlen (gfc_charlen *cl)
   cl->resolved = 1;
   saved_specification_expr = specification_expr;
   specification_expr = true;
+  saved_spec_expr_mod_proc = spec_expr_mod_proc;
+  if ((gfc_current_ns->proc_name
+       && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+      || (gfc_current_ns->parent && gfc_current_ns->parent->proc_name
+	  && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE))
+    spec_expr_mod_proc = true;
 
   if (cl->length_from_typespec)
     {
       if (gfc_resolve_expr (cl->length) == FAILURE)
 	{
 	  specification_expr = saved_specification_expr;
+	  spec_expr_mod_proc = saved_spec_expr_mod_proc;
 	  return FAILURE;
 	}
 
       if (gfc_simplify_expr (cl->length, 0) == FAILURE)
 	{
 	  specification_expr = saved_specification_expr;
+	  spec_expr_mod_proc = saved_spec_expr_mod_proc;
 	  return FAILURE;
 	}
     }
@@ -10703,6 +10738,7 @@  resolve_charlen (gfc_charlen *cl)
       if (resolve_index_expr (cl->length) == FAILURE)
 	{
 	  specification_expr = saved_specification_expr;
+	  spec_expr_mod_proc = saved_spec_expr_mod_proc;
 	  return FAILURE;
 	}
     }
@@ -10727,10 +10763,12 @@  resolve_charlen (gfc_charlen *cl)
     {
       gfc_error ("String length at %L is too large", &cl->length->where);
       specification_expr = saved_specification_expr;
+	  spec_expr_mod_proc = saved_spec_expr_mod_proc;
       return FAILURE;
     }
 
   specification_expr = saved_specification_expr;
+  spec_expr_mod_proc = saved_spec_expr_mod_proc;
   return SUCCESS;
 }
 
@@ -11192,7 +11230,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
   int no_init_flag, automatic_flag;
   gfc_expr *e;
   const char *auto_save_msg;
-  bool saved_specification_expr;
+  bool saved_specification_expr, saved_spec_expr_mod_proc;
 
   auto_save_msg = "Automatic object '%s' at %L cannot have the "
 		  "SAVE attribute";
@@ -11205,6 +11243,13 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
      is_non_constant_shape_array.  */
   saved_specification_expr = specification_expr;
   specification_expr = true;
+  saved_spec_expr_mod_proc = spec_expr_mod_proc;
+  if ((sym->attr.dummy || sym->attr.result || sym->attr.function)
+      && ((gfc_current_ns->proc_name
+	   && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+	  || (gfc_current_ns->parent && gfc_current_ns->parent->proc_name
+	  && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE)))
+    spec_expr_mod_proc = true;
 
   if (sym->ns->proc_name
       && (sym->ns->proc_name->attr.flavor == FL_MODULE
@@ -11219,6 +11264,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
       gfc_error ("The module or main program array '%s' at %L must "
 		 "have constant shape", sym->name, &sym->declared_at);
       specification_expr = saved_specification_expr;
+      spec_expr_mod_proc = saved_spec_expr_mod_proc;
       return FAILURE;
     }
 
@@ -11229,6 +11275,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 		 "requires either the pointer or allocatable attribute",
 		     sym->name, &sym->declared_at);
       specification_expr = saved_specification_expr;
+      spec_expr_mod_proc = saved_spec_expr_mod_proc;
       return FAILURE;
     }
 
@@ -11243,6 +11290,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	  gfc_error ("Entity with assumed character length at %L must be a "
 		     "dummy argument or a PARAMETER", &sym->declared_at);
 	  specification_expr = saved_specification_expr;
+	  spec_expr_mod_proc = saved_spec_expr_mod_proc;
 	  return FAILURE;
 	}
 
@@ -11250,6 +11298,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	{
 	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
 	  specification_expr = saved_specification_expr;
+	  spec_expr_mod_proc = saved_spec_expr_mod_proc;
 	  return FAILURE;
 	}
 
@@ -11264,6 +11313,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	      gfc_error ("'%s' at %L must have constant character length "
 			"in this context", sym->name, &sym->declared_at);
 	      specification_expr = saved_specification_expr;
+	      spec_expr_mod_proc = saved_spec_expr_mod_proc;
 	      return FAILURE;
 	    }
 	  if (sym->attr.in_common)
@@ -11271,6 +11321,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	      gfc_error ("COMMON variable '%s' at %L must have constant "
 			 "character length", sym->name, &sym->declared_at);
 	      specification_expr = saved_specification_expr;
+	      spec_expr_mod_proc = saved_spec_expr_mod_proc;
 	      return FAILURE;
 	    }
 	}
@@ -11302,6 +11353,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	{
 	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
 	  specification_expr = saved_specification_expr;
+	  spec_expr_mod_proc = saved_spec_expr_mod_proc;
 	  return FAILURE;
 	}
     }
@@ -11336,6 +11388,7 @@  resolve_fl_variable (gfc_symbol *sym, int mp_flag)
       else
 	goto no_init_error;
       specification_expr = saved_specification_expr;
+      spec_expr_mod_proc = saved_spec_expr_mod_proc;
       return FAILURE;
     }
 
@@ -11344,10 +11397,12 @@  no_init_error:
     {
       gfc_try res = resolve_fl_variable_derived (sym, no_init_flag);
       specification_expr = saved_specification_expr;
+      spec_expr_mod_proc = saved_spec_expr_mod_proc;
       return res;
     }
 
   specification_expr = saved_specification_expr;
+  spec_expr_mod_proc = saved_spec_expr_mod_proc;
   return SUCCESS;
 }
 
@@ -13151,7 +13206,7 @@  resolve_symbol (gfc_symbol *sym)
   gfc_component *c;
   symbol_attribute class_attr;
   gfc_array_spec *as;
-  bool saved_specification_expr;
+  bool saved_specification_expr, saved_spec_expr_mod_proc;
 
   if (sym->attr.artificial)
     return;
@@ -13699,8 +13754,19 @@  resolve_symbol (gfc_symbol *sym)
 
   saved_specification_expr = specification_expr;
   specification_expr = true;
+  saved_spec_expr_mod_proc = spec_expr_mod_proc;
+  if ((sym->attr.dummy || sym->attr.result || sym->attr.function)
+       && ((sym == sym->result && sym->ns->proc_name
+       && sym->ns->proc_name->attr.flavor == FL_MODULE)
+      || (sym != sym->result && sym->ns->parent
+	  && sym->ns->parent->proc_name
+	  && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)))
+    spec_expr_mod_proc = true;
+
   gfc_resolve_array_spec (sym->as, check_constant);
+
   specification_expr = saved_specification_expr;
+  spec_expr_mod_proc = saved_spec_expr_mod_proc;
 
   formal_arg_flag = 0;
 
diff --git a/gcc/testsuite/gfortran.dg/public_private_module_8.f90 b/gcc/testsuite/gfortran.dg/public_private_module_8.f90
new file mode 100644
index 0000000..8543320
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/public_private_module_8.f90
@@ -0,0 +1,52 @@ 
+! { dg-do compile }
+! { dg-options "-O2" }
+!
+! PR fortran/54884
+!
+! Check that get_key_len is not optimized away as it
+! is used in a publicly visible specification expression.
+!
+
+module m
+  private
+  public :: foo
+  interface foo
+    module procedure bar
+  end interface foo
+contains
+  pure function mylen()
+    integer :: mylen
+    mylen = 42
+  end function mylen
+  pure function myotherlen()
+    integer :: myotherlen
+    myotherlen = 99
+  end function myotherlen
+  subroutine bar(x)
+    character(len=mylen()) :: x
+    character :: z2(myotherlen())
+    call internal(x)
+    block
+       character(len=myotherlen()) :: z
+       z = "abc"
+       x(1:5) = z
+    end block
+!    x(6:10) = intern_func()
+  contains
+! The following currently fails as character lengths are
+! resolved separately; additionally intern_func's
+! sym->ns->proc_name is "bar".
+!    function intern_func()
+!      character(len=myotherlen()) :: intern_func
+!      intern_func = "zuzu"
+!    end function intern_func
+    subroutine internal(y)
+      character(len=myotherlen()) :: y
+      y = "abc"
+    end subroutine internal
+  end subroutine bar
+end module m
+
+! { dg-final { scan-assembler-not "__m_MOD_myotherlen" } }
+! { dg-final { scan-assembler "__m_MOD_bar" } }
+! { dg-final { scan-assembler "__m_MOD_mylen" } }