re PR debug/41558 (gfortran -O code excessive DW_OP_deref's)

	PR debug/41558
	* dwarf2out.c (loc_by_reference): Removed.
	(dw_loc_list_1): New function.
	(dw_loc_list): Remove toplev argument, add want_address argument.
	Don't look at decl_by_reference_p at all.  Use dw_loc_list_1.
	(loc_list_from_tree) <case VAR_DECL>: Pass want_address rather than
	want_address == 2 to dw_loc_list.  For successful dw_loc_list
	set have_address to 1 only if want_address is not 0.

	* gcc.dg/guality/guality.exp: Move gdb-test proc into...
	* lib/gcc-gdb-test.exp: ... here.  New file.
	* gfortran.dg/guality/guality.exp: New file.
	* gfortran.dg/guality/pr41558.f90: New test.
	* gfortran.dg/guality/arg1.f90: New test.

From-SVN: r152467

gcc/ChangeLog

+2009-10-05  Jakub Jelinek  <jakub@redhat.com>
+
+	PR debug/41558
+	* dwarf2out.c (loc_by_reference): Removed.
+	(dw_loc_list_1): New function.
+	(dw_loc_list): Remove toplev argument, add want_address argument.
+	Don't look at decl_by_reference_p at all.  Use dw_loc_list_1.
+	(loc_list_from_tree) <case VAR_DECL>: Pass want_address rather than
+	want_address == 2 to dw_loc_list.  For successful dw_loc_list
+	set have_address to 1 only if want_address is not 0.
+
 2009-10-05  Richard Sandiford  <rdsandiford@googlemail.com>
 
 	* config/mips/mips-protos.h (mips_trampoline_code_size): Declare.

gcc/dwarf2out.c

@@ -13596,71 +13596,101 @@ decl_by_reference_p (tree decl)
 	  && DECL_BY_REFERENCE (decl));
 }
 
+/* Return single element location list containing loc descr REF.  */
 
-/* Dereference a location expression LOC if DECL is passed by invisible
-   reference.  */
-
-static dw_loc_descr_ref
-loc_by_reference (dw_loc_descr_ref loc, tree decl)
+static dw_loc_list_ref
+single_element_loc_list (dw_loc_descr_ref ref)
 {
-  HOST_WIDE_INT size;
-  enum dwarf_location_atom op;
+  return new_loc_list (ref, NULL, NULL, NULL, 0);
+}
 
-  if (loc == NULL)
-    return NULL;
+/* Helper function for dw_loc_list.  Compute proper Dwarf location descriptor
+   for VARLOC.  */
 
-  if (!decl_by_reference_p (decl))
-    return loc;
+static dw_loc_descr_ref
+dw_loc_list_1 (tree loc, rtx varloc, int want_address,
+	       enum var_init_status initialized)
+{
+  int have_address = 0;
+  dw_loc_descr_ref descr;
+  enum machine_mode mode;
 
-  /* If loc is DW_OP_reg{0...31,x}, don't add DW_OP_deref, instead
-     change it into corresponding DW_OP_breg{0...31,x} 0.  Then the
-     location expression is considered to be address of a memory location,
-     rather than the register itself.  */
-  if (((loc->dw_loc_opc >= DW_OP_reg0 && loc->dw_loc_opc <= DW_OP_reg31)
-       || loc->dw_loc_opc == DW_OP_regx)
-      && (loc->dw_loc_next == NULL
-	  || (loc->dw_loc_next->dw_loc_opc == DW_OP_GNU_uninit
-	      && loc->dw_loc_next->dw_loc_next == NULL)))
+  if (want_address != 2)
     {
-      if (loc->dw_loc_opc == DW_OP_regx)
+      gcc_assert (GET_CODE (varloc) == VAR_LOCATION);
+      /* Single part.  */
+      if (GET_CODE (XEXP (varloc, 1)) != PARALLEL)
 	{
-	  loc->dw_loc_opc = DW_OP_bregx;
-	  loc->dw_loc_oprnd2.v.val_int = 0;
+	  varloc = XEXP (XEXP (varloc, 1), 0);
+	  mode = GET_MODE (varloc);
+	  if (MEM_P (varloc))
+	    {
+	      varloc = XEXP (varloc, 0);
+	      have_address = 1;
+	    }
+	  descr = mem_loc_descriptor (varloc, mode, initialized);
 	}
       else
+	return 0;
+    }
+  else
+    {
+      descr = loc_descriptor (varloc, DECL_MODE (loc), initialized);
+      have_address = 1;
+    }
+
+  if (!descr)
+    return 0;
+
+  if (want_address == 2 && !have_address
+      && (dwarf_version >= 4 || !dwarf_strict))
+    {
+      if (int_size_in_bytes (TREE_TYPE (loc)) > DWARF2_ADDR_SIZE)
 	{
-	  loc->dw_loc_opc
-	    = (enum dwarf_location_atom)
-	      (loc->dw_loc_opc + (DW_OP_breg0 - DW_OP_reg0));
-	  loc->dw_loc_oprnd1.v.val_int = 0;
+	  expansion_failed (loc, NULL_RTX,
+			    "DWARF address size mismatch");
+	  return 0;
 	}
-      return loc;
+      add_loc_descr (&descr, new_loc_descr (DW_OP_stack_value, 0, 0));
+      have_address = 1;
+    }
+  /* Show if we can't fill the request for an address.  */
+  if (want_address && !have_address)
+    {
+      expansion_failed (loc, NULL_RTX,
+			"Want address and only have value");
+      return 0;
     }
 
-  size = int_size_in_bytes (TREE_TYPE (decl));
-  if (size > DWARF2_ADDR_SIZE || size == -1)
-    return 0;
-  else if (size == DWARF2_ADDR_SIZE)
-    op = DW_OP_deref;
-  else
-    op = DW_OP_deref_size;
-  add_loc_descr (&loc, new_loc_descr (op, size, 0));
-  return loc;
-}
+  /* If we've got an address and don't want one, dereference.  */
+  if (!want_address && have_address)
+    {
+      HOST_WIDE_INT size = int_size_in_bytes (TREE_TYPE (loc));
+      enum dwarf_location_atom op;
 
-/* Return single element location list containing loc descr REF.  */
+      if (size > DWARF2_ADDR_SIZE || size == -1)
+	{
+	  expansion_failed (loc, NULL_RTX,
+			    "DWARF address size mismatch");
+	  return 0;
+	}
+      else if (size == DWARF2_ADDR_SIZE)
+	op = DW_OP_deref;
+      else
+	op = DW_OP_deref_size;
 
-static dw_loc_list_ref
-single_element_loc_list (dw_loc_descr_ref ref)
-{
-  return new_loc_list (ref, NULL, NULL, NULL, 0);
+      add_loc_descr (&descr, new_loc_descr (op, size, 0));
+    }
+
+  return descr;
 }
 
 /* Return dwarf representation of location list representing for
-   LOC_LIST of DECL.  */
+   LOC_LIST of DECL.  WANT_ADDRESS has the same meaning as in
+   loc_list_from_tree function.  */
 
 static dw_loc_list_ref
-dw_loc_list (var_loc_list * loc_list, tree decl, bool toplevel)
+dw_loc_list (var_loc_list * loc_list, tree decl, int want_address)
 {
   const char *endname, *secname;
   dw_loc_list_ref list;
@@ -13670,8 +13700,6 @@ dw_loc_list (var_loc_list * loc_list, tree decl, bool toplevel)
   dw_loc_descr_ref descr;
   char label_id[MAX_ARTIFICIAL_LABEL_BYTES];
 
-  bool by_reference = decl_by_reference_p (decl);
-
   /* Now that we know what section we are using for a base,
      actually construct the list of locations.
      The first location information is what is passed to the
@@ -13684,28 +13712,14 @@ dw_loc_list (var_loc_list * loc_list, tree decl, bool toplevel)
      a range of [last location start, end of function label].  */
 
   node = loc_list->first;
-  varloc = NOTE_VAR_LOCATION (node->var_loc_note);
   secname = secname_for_decl (decl);
 
   if (NOTE_VAR_LOCATION_LOC (node->var_loc_note))
     initialized = NOTE_VAR_LOCATION_STATUS (node->var_loc_note);
   else
     initialized = VAR_INIT_STATUS_INITIALIZED;
-
-  if (!toplevel || by_reference)
-    {
-      gcc_assert (GET_CODE (varloc) == VAR_LOCATION);
-      /* Single part.  */
-      if (GET_CODE (XEXP (varloc, 1)) != PARALLEL)
-	descr = loc_by_reference (mem_loc_descriptor (XEXP (XEXP (varloc, 1), 0),
-						      TYPE_MODE (TREE_TYPE (decl)),
-						      initialized),
-				  decl);
-      else
-	descr = NULL;
-    }
-  else
-    descr = loc_descriptor (varloc, DECL_MODE (decl), initialized);
+  varloc = NOTE_VAR_LOCATION (node->var_loc_note);
+  descr = dw_loc_list_1 (decl, varloc, want_address, initialized);
 
   if (loc_list && loc_list->first != loc_list->last)
     list = new_loc_list (descr, node->label, node->next->label, secname, 1);
@@ -13721,22 +13735,9 @@ dw_loc_list (var_loc_list * loc_list, tree decl, bool toplevel)
       {
 	/* The variable has a location between NODE->LABEL and
 	   NODE->NEXT->LABEL.  */
-	enum var_init_status initialized =
-	  NOTE_VAR_LOCATION_STATUS (node->var_loc_note);
+	initialized = NOTE_VAR_LOCATION_STATUS (node->var_loc_note);
 	varloc = NOTE_VAR_LOCATION (node->var_loc_note);
-	if (!toplevel || by_reference)
-	  {
-	    gcc_assert (GET_CODE (varloc) == VAR_LOCATION);
-	    /* Single part.  */
-	    if (GET_CODE (XEXP (varloc, 1)) != PARALLEL)
-	      descr = mem_loc_descriptor (XEXP (XEXP (varloc, 1), 0),
-	      				  TYPE_MODE (TREE_TYPE (decl)), initialized);
-	    else
-	      descr = NULL;
-	    descr = loc_by_reference (descr, decl);
-	  }
-	else
-	  descr = loc_descriptor (varloc, DECL_MODE (decl), initialized);
+	descr = dw_loc_list_1 (decl, varloc, want_address, initialized);
 	add_loc_descr_to_loc_list (&list, descr,
 				   node->label, node->next->label, secname);
       }
@@ -13745,9 +13746,6 @@ dw_loc_list (var_loc_list * loc_list, tree decl, bool toplevel)
      it keeps its location until the end of function.  */
   if (NOTE_VAR_LOCATION_LOC (node->var_loc_note) != NULL_RTX)
     {
-      enum var_init_status initialized =
-	NOTE_VAR_LOCATION_STATUS (node->var_loc_note);
-
       if (!current_function_decl)
 	endname = text_end_label;
       else
@@ -13757,20 +13755,9 @@ dw_loc_list (var_loc_list * loc_list, tree decl, bool toplevel)
 	  endname = ggc_strdup (label_id);
 	}
 
+      initialized = NOTE_VAR_LOCATION_STATUS (node->var_loc_note);
       varloc = NOTE_VAR_LOCATION (node->var_loc_note);
-      if (!toplevel || by_reference)
-	{
-	  gcc_assert (GET_CODE (varloc) == VAR_LOCATION);
-	  /* Single part.  */
-	  if (GET_CODE (XEXP (varloc, 1)) != PARALLEL)
-	    descr = mem_loc_descriptor (XEXP (XEXP (varloc, 1), 0),
-	    				TYPE_MODE (TREE_TYPE (decl)), initialized);
-	  else
-	    descr = NULL;
-	  descr = loc_by_reference (descr, decl);
-	}
-      else
-	descr = loc_descriptor (varloc, DECL_MODE (decl), initialized);
+      descr = dw_loc_list_1 (decl, varloc, want_address, initialized);
       add_loc_descr_to_loc_list (&list, descr, node->label, endname, secname);
     }
   return list;
@@ -13948,11 +13935,7 @@ loc_list_for_address_of_addr_expr_of_indirect_ref (tree loc, bool toplev)
    If WANT_ADDRESS is 1, expression computing address of LOC will be returned
    if WANT_ADDRESS is 2, expression computing address useable in location
      will be returned (i.e. DW_OP_reg can be used
-     to refer to register values) 
-   TODO: Dwarf4 adds types to the stack machine that ought to be used here
-   DW_OP_stack_value will help in cases where we fail to find address of the
-   expression.
- */
+     to refer to register values).  */
 
 static dw_loc_list_ref
 loc_list_from_tree (tree loc, int want_address)
@@ -14087,8 +14070,8 @@ loc_list_from_tree (tree loc, int want_address)
 	var_loc_list *loc_list = lookup_decl_loc (loc);
 
 	if (loc_list && loc_list->first
-	    && (list_ret = dw_loc_list (loc_list, loc, want_address == 2)))
-	  have_address = 1;
+	    && (list_ret = dw_loc_list (loc_list, loc, want_address)))
+	  have_address = want_address != 0;
 	else if (rtl == NULL_RTX)
 	  {
 	    expansion_failed (loc, NULL_RTX, "DECL has no RTL");

gcc/testsuite/ChangeLog

+2009-10-05  Jakub Jelinek  <jakub@redhat.com>
+
+	PR debug/41558
+	* gcc.dg/guality/guality.exp: Move gdb-test proc into...
+	* lib/gcc-gdb-test.exp: ... here.  New file.
+	* gfortran.dg/guality/guality.exp: New file.
+	* gfortran.dg/guality/pr41558.f90: New test.
+	* gfortran.dg/guality/arg1.f90: New test.
+
 2009-10-05  Paul Thomas  <pault@gcc.gnu.org>
 
 	* gfortran.dg/dynamic_dispatch_1.f90: New test.

gcc/testsuite/gcc.dg/guality/guality.exp

 # This harness is for tests that should be run at all optimisation levels.
 
 load_lib gcc-dg.exp
+load_lib gcc-gdb-test.exp
 
 # Disable on darwin until radr://7264615 is resolved.
 if { [istarget *-*-darwin*] } {
@@ -20,82 +21,6 @@ proc check_guality {args} {
     return $ret
 }
 
-# Utility for testing variable values using gdb, invoked via dg-final.
-# Call pass if variable has the desired value, otherwise fail.
-#
-# Argument 0 is the line number on which to put a breakpoint
-# Argument 1 is the name of the variable to be checked
-# Argument 2 is the expected value of the variable
-# Argument 3 handles expected failures and the like
-proc gdb-test { args } {
-    if { ![isnative] || [is_remote target] } { return }
-
-    if { [llength $args] >= 4 } {
-	switch [dg-process-target [lindex $args 3]] {
-	    "S" { }
-	    "N" { return }
-	    "F" { setup_xfail "*-*-*" }
-	    "P" { }
-	}
-    }
-
-    # This assumes that we are three frames down from dg-test, and that
-    # it still stores the filename of the testcase in a local variable "name".
-    # A cleaner solution would require a new DejaGnu release.
-    upvar 2 name testcase
-    upvar 2 prog prog
-
-    set gdb_name $::env(GUALITY_GDB_NAME)
-    set testname "$testcase line [lindex $args 0] [lindex $args 1] == [lindex $args 2]"
-    set output_file "[file rootname [file tail $prog]].exe"
-    set cmd_file "[file rootname [file tail $prog]].gdb"
-
-    set fd [open $cmd_file "w"]
-    puts $fd "break [lindex $args 0]"
-    puts $fd "run"
-    puts $fd "print [lindex $args 1]"
-    puts $fd "print [lindex $args 2]"
-    puts $fd "quit"
-    close $fd
-
-    send_log "Spawning: $gdb_name -nx -nw -quiet -x $cmd_file ./$output_file\n"
-    set res [remote_spawn target "$gdb_name -nx -nw -quiet -x $cmd_file ./$output_file"]
-    if { $res < 0 || $res == "" } {
-	unsupported "$testname"
-	return
-    }
-
-    remote_expect target [timeout_value] {
-	-re {[\n\r]\$1 = ([^\n\r]*)[\n\r]+\$2 = ([^\n\r]*)[\n\r]} {
-	    set first $expect_out(1,string)
-	    set second $expect_out(2,string)
-	    if { $first == $second } {
-		pass "$testname"
-	    } else {
-		send_log "$first != $second\n"
-		fail "$testname"
-	    }
-	    remote_close target
-	    return
-	}
-	# Too old GDB
-	-re "Unhandled dwarf expression|Error in sourced command file" {
-	    unsupported "$testname"
-	    remote_close target
-	    return
-	}
-	timeout {
-	    unsupported "$testname"
-	    remote_close target
-	    return
-	}
-    }
-
-    remote_close target
-    unsupported "$testname"
-    return
-}
-
 dg-init
 
 global GDB

gcc/testsuite/gfortran.dg/guality/arg1.f90

+! { dg-do run }
+! { dg-options "-g" }
+  integer :: a(10), b(12)
+  call sub (a, 10)
+  call sub (b, 12)
+  write (*,*) a, b
+end
+
+subroutine sub (a, n)
+  integer :: a(n), n
+  do i = 1, n
+    a(i) = i
+  end do
+  write (*,*) a	! { dg-final { gdb-test 14 "a(10)" "10" } }
+end subroutine

gcc/testsuite/gfortran.dg/guality/guality.exp

+# This harness is for tests that should be run at all optimisation levels.
+
+load_lib gfortran-dg.exp
+load_lib gcc-gdb-test.exp
+
+# Disable on darwin until radr://7264615 is resolved.
+if { [istarget *-*-darwin*] } {
+  return
+}
+
+dg-init
+
+global GDB
+if ![info exists ::env(GUALITY_GDB_NAME)] {
+    if [info exists GDB] {
+	set guality_gdb_name "$GDB"
+    } else {
+	set guality_gdb_name "[transform gdb]"
+    }
+    setenv GUALITY_GDB_NAME "$guality_gdb_name"
+}
+
+gfortran-dg-runtest [lsort [glob $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] ""
+
+if [info exists guality_gdb_name] {
+    unsetenv GUALITY_GDB_NAME
+}
+
+dg-finish

gcc/testsuite/gfortran.dg/guality/pr41558.f90

+! PR debug/41558
+! { dg-do run }
+! { dg-options "-g" }
+
+subroutine f (s)
+  character(len=3) :: s
+  write (*,*), s ! { dg-final { gdb-test 7 "s" "'foo'" } }
+end
+  call f ('foo')
+end

gcc/testsuite/lib/gcc-gdb-test.exp

+#   Copyright (C) 2009 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+#
+# This program 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/>.
+
+# Utility for testing variable values using gdb, invoked via dg-final.
+# Call pass if variable has the desired value, otherwise fail.
+#
+# Argument 0 is the line number on which to put a breakpoint
+# Argument 1 is the name of the variable to be checked
+# Argument 2 is the expected value of the variable
+# Argument 3 handles expected failures and the like
+proc gdb-test { args } {
+    if { ![isnative] || [is_remote target] } { return }
+
+    if { [llength $args] >= 4 } {
+	switch [dg-process-target [lindex $args 3]] {
+	    "S" { }
+	    "N" { return }
+	    "F" { setup_xfail "*-*-*" }
+	    "P" { }
+	}
+    }
+
+    # This assumes that we are three frames down from dg-test, and that
+    # it still stores the filename of the testcase in a local variable "name".
+    # A cleaner solution would require a new DejaGnu release.
+    upvar 2 name testcase
+    upvar 2 prog prog
+
+    set gdb_name $::env(GUALITY_GDB_NAME)
+    set testname "$testcase line [lindex $args 0] [lindex $args 1] == [lindex $args 2]"
+    set output_file "[file rootname [file tail $prog]].exe"
+    set cmd_file "[file rootname [file tail $prog]].gdb"
+
+    set fd [open $cmd_file "w"]
+    puts $fd "break [lindex $args 0]"
+    puts $fd "run"
+    puts $fd "print [lindex $args 1]"
+    puts $fd "print [lindex $args 2]"
+    puts $fd "quit"
+    close $fd
+
+    send_log "Spawning: $gdb_name -nx -nw -quiet -x $cmd_file ./$output_file\n"
+    set res [remote_spawn target "$gdb_name -nx -nw -quiet -x $cmd_file ./$output_file"]
+    if { $res < 0 || $res == "" } {
+	unsupported "$testname"
+	return
+    }
+
+    remote_expect target [timeout_value] {
+	-re {[\n\r]\$1 = ([^\n\r]*)[\n\r]+\$2 = ([^\n\r]*)[\n\r]} {
+	    set first $expect_out(1,string)
+	    set second $expect_out(2,string)
+	    if { $first == $second } {
+		pass "$testname"
+	    } else {
+		send_log "$first != $second\n"
+		fail "$testname"
+	    }
+	    remote_close target
+	    return
+	}
+	# Too old GDB
+	-re "Unhandled dwarf expression|Error in sourced command file" {
+	    unsupported "$testname"
+	    remote_close target
+	    return
+	}
+	timeout {
+	    unsupported "$testname"
+	    remote_close target
+	    return
+	}
+    }
+
+    remote_close target
+    unsupported "$testname"
+    return
+}