re PR debug/37738 (Fortran DW_TAG_common_block has incorrect placement/scope)

	PR debug/37738
	* dwarf2out.c (common_block_die_table): New variable.
	(common_block_die_table_hash, common_block_die_table_eq): New
	functions.
	(gen_variable_die): Look up a DW_TAG_common_block die for a particular
	COMMON block in the current scope rather than globally.  Optimize
	DW_OP_addr SYMBOL_REF DW_OP_plus_uconst off into
	DW_OP_addr SYMBOL_REF+off.

	* gfortran.dg/debug/pr37738.f: New test.

From-SVN: r140944

4 files changed, 109 insertions, 4 deletions

diff --git a/gcc/ChangeLog b/gcc/ChangeLog
index a2c1ae3..5582866 100644
--- a/gcc/ChangeLog
+++ b/gcc/ChangeLog
@@ -1,3 +1,14 @@
+2008-10-07  Jakub Jelinek  <jakub@redhat.com>
+
+	PR debug/37738
+	* dwarf2out.c (common_block_die_table): New variable.
+	(common_block_die_table_hash, common_block_die_table_eq): New
+	functions.
+	(gen_variable_die): Look up a DW_TAG_common_block die for a particular
+	COMMON block in the current scope rather than globally.  Optimize
+	DW_OP_addr SYMBOL_REF DW_OP_plus_uconst off into
+	DW_OP_addr SYMBOL_REF+off.
+
 2008-10-07  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* tree-ssa-loop-ivopts.c (may_be_nonaddressable_p) <VIEW_CONVERT_EXPR>:
diff --git a/gcc/dwarf2out.c b/gcc/dwarf2out.c
index 37bf21f..ed4d74d 100644
--- a/gcc/dwarf2out.c
+++ b/gcc/dwarf2out.c
@@ -4748,6 +4748,10 @@ static GTY((param_is (struct dwarf_file_data))) htab_t file_table;
    The key is a DECL_UID() which is a unique number identifying each decl.  */
 static GTY ((param_is (struct die_struct))) htab_t decl_die_table;
 
+/* A hash table of references to DIE's that describe COMMON blocks.
+   The key is DECL_UID() ^ die_parent.  */
+static GTY ((param_is (struct die_struct))) htab_t common_block_die_table;
+
 /* Node of the variable location list.  */
 struct var_loc_node GTY ((chain_next ("%h.next")))
 {
@@ -4960,6 +4964,8 @@ static void equate_type_number_to_die (tree, dw_die_ref);
 static hashval_t decl_die_table_hash (const void *);
 static int decl_die_table_eq (const void *, const void *);
 static dw_die_ref lookup_decl_die (tree);
+static hashval_t common_block_die_table_hash (const void *);
+static int common_block_die_table_eq (const void *, const void *);
 static hashval_t decl_loc_table_hash (const void *);
 static int decl_loc_table_eq (const void *, const void *);
 static var_loc_list *lookup_decl_loc (const_tree);
@@ -13812,6 +13818,26 @@ gen_subprogram_die (tree decl, dw_die_ref context_die)
 
 }
 
+/* Returns a hash value for X (which really is a die_struct).  */
+
+static hashval_t
+common_block_die_table_hash (const void *x)
+{
+  const_dw_die_ref d = (const_dw_die_ref) x;
+  return (hashval_t) d->decl_id ^ htab_hash_pointer (d->die_parent);
+}
+
+/* Return nonzero if decl_id and die_parent of die_struct X is the same
+   as decl_id and die_parent of die_struct Y.  */
+
+static int
+common_block_die_table_eq (const void *x, const void *y)
+{
+  const_dw_die_ref d = (const_dw_die_ref) x;
+  const_dw_die_ref e = (const_dw_die_ref) y;
+  return d->decl_id == e->decl_id && d->die_parent == e->die_parent;
+}
+
 /* Generate a DIE to represent a declared data object.  */
 
 static void
@@ -13853,6 +13879,7 @@ gen_variable_die (tree decl, dw_die_ref context_die)
       tree field;
       dw_die_ref com_die;
       dw_loc_descr_ref loc;
+      die_node com_die_arg;
 
       var_die = lookup_decl_die (decl);
       if (var_die)
@@ -13863,21 +13890,41 @@ gen_variable_die (tree decl, dw_die_ref context_die)
 	      if (loc)
 		{
 		  if (off)
-		    add_loc_descr (&loc, new_loc_descr (DW_OP_plus_uconst,
+		    {
+		      /* Optimize the common case.  */
+		      if (loc->dw_loc_opc == DW_OP_addr
+			  && loc->dw_loc_next == NULL
+			  && GET_CODE (loc->dw_loc_oprnd1.v.val_addr)
+			     == SYMBOL_REF)
+			loc->dw_loc_oprnd1.v.val_addr
+			  = plus_constant (loc->dw_loc_oprnd1.v.val_addr, off);
+			else
+			  add_loc_descr (&loc,
+					 new_loc_descr (DW_OP_plus_uconst,
 							off, 0));
+		    }
 		  add_AT_loc (var_die, DW_AT_location, loc);
 		  remove_AT (var_die, DW_AT_declaration);
 		}
 	    }
 	  return;
 	}
+
+      if (common_block_die_table == NULL)
+	common_block_die_table
+	  = htab_create_ggc (10, common_block_die_table_hash,
+			     common_block_die_table_eq, NULL);
+
       field = TREE_OPERAND (DECL_VALUE_EXPR (decl), 0);
-      com_die = lookup_decl_die (com_decl);
+      com_die_arg.decl_id = DECL_UID (com_decl);
+      com_die_arg.die_parent = context_die;
+      com_die = (dw_die_ref) htab_find (common_block_die_table, &com_die_arg);
       loc = loc_descriptor_from_tree (com_decl);
       if (com_die == NULL)
 	{
 	  const char *cnam
 	    = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (com_decl));
+	  void **slot;
 
 	  com_die = new_die (DW_TAG_common_block, context_die, decl);
 	  add_name_and_src_coords_attributes (com_die, com_decl);
@@ -13891,7 +13938,9 @@ gen_variable_die (tree decl, dw_die_ref context_die)
           else if (DECL_EXTERNAL (decl))
 	    add_AT_flag (com_die, DW_AT_declaration, 1);
 	  add_pubname_string (cnam, com_die); /* ??? needed? */
-	  equate_decl_number_to_die (com_decl, com_die);
+	  com_die->decl_id = DECL_UID (com_decl);
+	  slot = htab_find_slot (common_block_die_table, com_die, INSERT);
+	  *slot = (void *) com_die;
 	}
       else if (get_AT (com_die, DW_AT_location) == NULL && loc)
 	{
@@ -13907,7 +13956,17 @@ gen_variable_die (tree decl, dw_die_ref context_die)
       if (loc)
 	{
 	  if (off)
-	    add_loc_descr (&loc, new_loc_descr (DW_OP_plus_uconst, off, 0));
+	    {
+	      /* Optimize the common case.  */
+	      if (loc->dw_loc_opc == DW_OP_addr
+		  && loc->dw_loc_next == NULL
+		  && GET_CODE (loc->dw_loc_oprnd1.v.val_addr) == SYMBOL_REF)
+		loc->dw_loc_oprnd1.v.val_addr
+		  = plus_constant (loc->dw_loc_oprnd1.v.val_addr, off);
+	      else
+		add_loc_descr (&loc, new_loc_descr (DW_OP_plus_uconst,
+						    off, 0));
+	    }
 	  add_AT_loc (var_die, DW_AT_location, loc);
 	}
       else if (DECL_EXTERNAL (decl))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4ad05b0..d3fdf00 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2008-10-07  Jakub Jelinek  <jakub@redhat.com>
+
+	PR debug/37738
+	* gfortran.dg/debug/pr37738.f: New test.
+
 2008-10-07  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/loop_optimization4.adb: New test.
diff --git a/gcc/testsuite/gfortran.dg/debug/pr37738.f b/gcc/testsuite/gfortran.dg/debug/pr37738.f
new file mode 100644
index 0000000..b0a787b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/debug/pr37738.f
@@ -0,0 +1,30 @@
+C PR debug/37738
+C { dg-do compile }
+C { dg-skip-if "DWARF-2 only" { "*-*-*" } { "*" } { "-gdwarf-2" } }
+C { dg-options "-dA" }
+
+      subroutine a
+      integer*4 a_i, c_i
+      common /block/a_i, c_i
+      a_i = 1
+      c_i = 4
+      end subroutine a
+      subroutine b
+      integer*4 b_i
+      common /block/b_i, d_i
+      b_i = 2
+      d_i = 5
+      end subroutine b
+      subroutine c
+      integer*4 a_i, c_i
+      common /block/a_i, c_i
+      if (a_i .ne. 2) call abort
+      if (c_i .ne. 5) call abort
+      end subroutine c
+      program abc
+      call a
+      call b
+      call c
+      end program abc
+
+C { dg-final { scan-assembler-times "DIE\[^\n\]*DW_TAG_common_block" 3 } }