utils2.c (build_allocator): Set TREE_THIS_NOTRAP on the dereference of the pointer...

	* gcc-interface/utils2.c (build_allocator): Set TREE_THIS_NOTRAP on the
	dereference of the pointer to the storage area.  Remove useless type
	conversions and factor out common code.

From-SVN: r179187

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4a4b64ea1217d2bf84084b147ee1a1f0cb07cc56..15ef0b557b3cd4d2e0b4499ab6874021eafe8626 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2011-09-26  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gcc-interface/utils2.c (build_allocator): Set TREE_THIS_NOTRAP on the
+       dereference of the pointer to the storage area.  Remove useless type
+       conversions and factor out common code.
+
 2011-09-26  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gcc-interface/utils.c (maybe_unconstrained_array): Declare TYPE local

diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index b9906b1f4652ed290425cff3eee9d63657ad60bd..cf290a397b148de99ecbd016c8bfd74469873a7c 100644 (file)
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -2112,9 +2112,9 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
     }
 }
 \f
-/* Build a GCC tree to correspond to allocating an object of TYPE whose
+/* Build a GCC tree that corresponds to allocating an object of TYPE whose
    initial value is INIT, if INIT is nonzero.  Convert the expression to
-   RESULT_TYPE, which must be some type of pointer.  Return the tree.
+   RESULT_TYPE, which must be some pointer type, and return the result.
 
    GNAT_PROC and GNAT_POOL optionally give the procedure to call and
    the storage pool to use.  GNAT_NODE is used to provide an error
@@ -2127,8 +2127,7 @@ tree
 build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
                  Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
 {
-  tree size = TYPE_SIZE_UNIT (type);
-  tree result;
+  tree size, storage, storage_deref, storage_init;
 
   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
   if (init && TREE_CODE (init) == NULL_EXPR)
@@ -2154,19 +2153,19 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
                                          get_identifier ("ALLOC"), false);
       tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
       tree storage_ptr_type = build_pointer_type (storage_type);
-      tree storage;
 
       size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
                                             init);
 
-      /* If the size overflows, pass -1 so the allocator will raise
-        storage error.  */
+      /* If the size overflows, pass -1 so Storage_Error will be raised.  */
       if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
        size = ssize_int (-1);
 
       storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type,
                                          gnat_proc, gnat_pool, gnat_node);
       storage = convert (storage_ptr_type, gnat_protect_expr (storage));
+      storage_deref = build_unary_op (INDIRECT_REF, NULL_TREE, storage);
+      TREE_THIS_NOTRAP (storage_deref) = 1;
 
       /* If there is an initializing expression, then make a constructor for
         the entire object including the bounds and copy it into the object.
@@ -2179,29 +2178,24 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
                                  build_template (template_type, type, init));
          CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (storage_type)),
                                  init);
-         return convert
-           (result_type,
-            build2 (COMPOUND_EXPR, storage_ptr_type,
-                    build_binary_op
-                    (MODIFY_EXPR, NULL_TREE,
-                     build_unary_op (INDIRECT_REF, NULL_TREE,
-                                     convert (storage_ptr_type, storage)),
-                     gnat_build_constructor (storage_type, v)),
-                    convert (storage_ptr_type, storage)));
+         storage_init
+           = build_binary_op (MODIFY_EXPR, NULL_TREE, storage_deref,
+                              gnat_build_constructor (storage_type, v));
        }
       else
-       return build2
-         (COMPOUND_EXPR, result_type,
-          build_binary_op
-          (MODIFY_EXPR, NULL_TREE,
-           build_component_ref
-           (build_unary_op (INDIRECT_REF, NULL_TREE,
-                            convert (storage_ptr_type, storage)),
-            NULL_TREE, TYPE_FIELDS (storage_type), false),
-           build_template (template_type, type, NULL_TREE)),
-          convert (result_type, convert (storage_ptr_type, storage)));
+       storage_init
+         = build_binary_op (MODIFY_EXPR, NULL_TREE,
+                            build_component_ref (storage_deref, NULL_TREE,
+                                                 TYPE_FIELDS (storage_type),
+                                                 false),
+                            build_template (template_type, type, NULL_TREE));
+
+      return build2 (COMPOUND_EXPR, result_type,
+                    storage_init, convert (result_type, storage));
     }
 
+  size = TYPE_SIZE_UNIT (type);
+
   /* If we have an initializing expression, see if its size is simpler
      than the size from the type.  */
   if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init))
@@ -2221,32 +2215,28 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
        size = max_size (size, true);
     }
 
-  /* If the size overflows, pass -1 so the allocator will raise
-     storage error.  */
+  /* If the size overflows, pass -1 so Storage_Error will be raised.  */
   if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
     size = ssize_int (-1);
 
-  result = convert (result_type,
-                   build_call_alloc_dealloc (NULL_TREE, size, type,
-                                             gnat_proc, gnat_pool,
-                                             gnat_node));
+  storage = convert (result_type,
+                    build_call_alloc_dealloc (NULL_TREE, size, type,
+                                              gnat_proc, gnat_pool,
+                                              gnat_node));
 
   /* If we have an initial value, protect the new address, assign the value
      and return the address with a COMPOUND_EXPR.  */
   if (init)
     {
-      result = gnat_protect_expr (result);
-      result
-       = build2 (COMPOUND_EXPR, TREE_TYPE (result),
-                 build_binary_op
-                 (MODIFY_EXPR, NULL_TREE,
-                  build_unary_op (INDIRECT_REF,
-                                  TREE_TYPE (TREE_TYPE (result)), result),
-                  init),
-                 result);
+      storage = gnat_protect_expr (storage);
+      storage_deref = build_unary_op (INDIRECT_REF, NULL_TREE, storage);
+      TREE_THIS_NOTRAP (storage_deref) = 1;
+      storage_init
+       = build_binary_op (MODIFY_EXPR, NULL_TREE, storage_deref, init);
+      return build2 (COMPOUND_EXPR, result_type, storage_init, storage);
     }
 
-  return convert (result_type, result);
+  return storage;
 }
 \f
 /* Indicate that we need to take the address of T and that it therefore

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8f11de15e55379c2002ee5bd6b0a3733853f3c6f..e7e259465d5dca8807cc0ddbe712a0218bc079b9 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-09-26  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gnat.dg/opt20.ad[sb]: New test.
+       * gnat.dg/opt20_pkg.ads: New helper.
+
 2011-09-26  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/array17.adb: New test.

diff --git a/gcc/testsuite/gnat.dg/opt20.adb b/gcc/testsuite/gnat.dg/opt20.adb
new file mode 100644 (file)
index 0000000..6d3e240
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/opt20.adb
@@ -0,0 +1,15 @@
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+package body Opt20 is
+
+   type Build_Mode_State is (None, Static, Dynamic, Relocatable);
+
+   procedure Build_Library (For_Project : Integer) is
+      Project_Name : constant String := Get_Name_String (For_Project);
+      The_Build_Mode : Build_Mode_State := None;
+   begin
+      Fail (Project_Name);
+      Write_Str (To_Lower (Build_Mode_State'Image (The_Build_Mode)));
+   end;
+
+end Opt20;

diff --git a/gcc/testsuite/gnat.dg/opt20.ads b/gcc/testsuite/gnat.dg/opt20.ads
new file mode 100644 (file)
index 0000000..58833bf
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/opt20.ads
@@ -0,0 +1,10 @@
+-- { dg-do compile }
+-- { dg-options "-O2 -gnatpn" }
+
+with Opt20_Pkg; use Opt20_Pkg;
+
+package Opt20 is
+
+   procedure Build_Library (For_Project : Integer);
+
+end Opt20;

diff --git a/gcc/testsuite/gnat.dg/opt20_pkg.ads b/gcc/testsuite/gnat.dg/opt20_pkg.ads
new file mode 100644 (file)
index 0000000..2b9b3e8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/opt20_pkg.ads
@@ -0,0 +1,13 @@
+package Opt20_Pkg is
+
+   procedure Write_Str (S : String);
+
+   type Fail_Proc is access procedure (S : String);
+
+   procedure My_Fail (S : String);
+
+   Fail : Fail_Proc := My_Fail'Access;
+
+   function Get_Name_String (Id : Integer) return String;
+
+end Opt20_Pkg;