gcc/gcc43-pr37738.patch

2008-10-07  Jakub Jelinek  <jakub@redhat.com>

	* f95-lang.c (poplevel): Don't clear BLOCK_VARS if functionbody.
	* trans-decl.c (gfc_build_qualified_array): Build accurate debug type
	even if nest.
	(build_entry_thunks, gfc_generate_function_code,
	gfc_generate_constructors): Ensure DECL_SAVED_TREE is a BIND_EXPR
	with DECL_INITIAL as its BLOCK.

	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.

--- gcc/testsuite/gfortran.dg/debug/pr37738.f	(revision 0)
+++ gcc/testsuite/gfortran.dg/debug/pr37738.f	(revision 140945)
@@ -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 } }
--- gcc/dwarf2out.c	(revision 140943)
+++ gcc/dwarf2out.c	(revision 140945)
@@ -4748,6 +4748,10 @@ static GTY((param_is (struct dwarf_file_
    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 (t
 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_re
 
 }
 
+/* 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 
       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 
 	      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 
           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 
       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))
--- gcc/fortran/f95-lang.c	(revision 140943)
+++ gcc/fortran/f95-lang.c	(revision 140945)
@@ -457,14 +457,8 @@ poplevel (int keep, int reverse, int fun
   current_binding_level = current_binding_level->level_chain;
 
   if (functionbody)
-    {
-      /* This is the top level block of a function. The ..._DECL chain stored
-         in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
-         leave them in the BLOCK because they are found in the FUNCTION_DECL
-         instead.  */
-      DECL_INITIAL (current_function_decl) = block_node;
-      BLOCK_VARS (block_node) = 0;
-    }
+    /* This is the top level block of a function. */
+    DECL_INITIAL (current_function_decl) = block_node;
   else if (current_binding_level == global_binding_level)
     /* When using gfc_start_block/gfc_finish_block from middle-end hooks,
        don't add newly created BLOCKs as sublocks of global_binding_level.  */
--- gcc/fortran/trans-decl.c	(revision 140943)
+++ gcc/fortran/trans-decl.c	(revision 140945)
@@ -704,7 +704,7 @@ gfc_build_qualified_array (tree decl, gf
       layout_type (type);
     }
 
-  if (nest || write_symbols == NO_DEBUG)
+  if (write_symbols == NO_DEBUG)
     return;
 
   if (TYPE_NAME (type) != NULL_TREE
@@ -1761,7 +1761,7 @@ build_entry_thunks (gfc_namespace * ns)
 
       thunk_fndecl = thunk_sym->backend_decl;
 
-      gfc_start_block (&body);
+      gfc_init_block (&body);
 
       /* Pass extra parameter identifying this entry point.  */
       tmp = build_int_cst (gfc_array_index_type, el->id);
@@ -1869,8 +1869,12 @@ build_entry_thunks (gfc_namespace * ns)
 
       /* Finish off this function and send it for code generation.  */
       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
+      tmp = getdecls ();
       poplevel (1, 0, 1);
       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
+      DECL_SAVED_TREE (thunk_fndecl)
+	= build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
+		    DECL_INITIAL (thunk_fndecl));
 
       /* Output the GENERIC tree.  */
       dump_function (TDI_original, thunk_fndecl);
@@ -3652,7 +3656,7 @@ gfc_generate_function_code (gfc_namespac
 
   trans_function_start (sym);
 
-  gfc_start_block (&block);
+  gfc_init_block (&block);
 
   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
     {
@@ -3886,11 +3890,16 @@ gfc_generate_function_code (gfc_namespac
   saved_function_decls = NULL_TREE;
 
   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
+  decl = getdecls ();
 
   /* Finish off this function and send it for code generation.  */
   poplevel (1, 0, 1);
   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
 
+  DECL_SAVED_TREE (fndecl)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+		DECL_INITIAL (fndecl));
+
   /* Output the GENERIC tree.  */
   dump_function (TDI_original, fndecl);
 
@@ -3969,9 +3978,13 @@ gfc_generate_constructors (void)
       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
     }
 
+  decl = getdecls ();
   poplevel (1, 0, 1);
 
   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+  DECL_SAVED_TREE (fndecl)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+		DECL_INITIAL (fndecl));
 
   free_after_parsing (cfun);
   free_after_compilation (cfun);