This pach modifies the expansion related to initialization calls and secondary
stack usage to inspec the components of a type derived from Limited_Controlled
or Controlled. Previously controlled types were treated as never utilizing the
secondary stack, however this is not true because a controlled type may contain
a component initialized by a function which returns on the secondary stack.

------------
-- Source --
------------

--  pack1.ads

with Ada.Finalization; use Ada.Finalization;

package Pack1 is
   type Ctrl is new Controlled with record
      Comp : Integer;
   end record;

   function Make_Ctrl return Ctrl;
end Pack1;

--  pack1.adb

package body Pack1 is
   Empty : constant Ctrl := (Controlled with Comp => 123);

   function Make_Ctrl return Ctrl is
   begin
      return Empty;
   end Make_Ctrl;
end Pack1;

--  pack2.ads

with Ada.Finalization; use Ada.Finalization;
with Pack1;            use Pack1;

package Pack2 is
   type Ctrl_Wrap is new Controlled with record
      Comp : Ctrl := Make_Ctrl;
   end record;
end Pack2;

--  main.adb

with Pack2; use Pack2;

procedure Main is
   procedure Make_Ctrl_Wrap is
      Obj : Ctrl_Wrap;
      pragma Warnings (Off, Obj);
   begin null; end Make_Ctrl_Wrap;

begin
   for Iter in 1 .. 10_000 loop
      Make_Ctrl_Wrap;
   end loop;
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q main.adb
$ valgrind ./main >& valgrind.log
$ grep -c "still reachable" valgrind.log
0

Tested on x86_64-pc-linux-gnu, committed on trunk

2018-01-11  Hristian Kirtchev  <kirtc...@adacore.com>

gcc/ada/

        * sem_res.adb (Uses_SS): A controlled type requires the secondary stack
        if it contains at least one component declaration employing a function
        call returning on the secondary stack.
--- gcc/ada/sem_res.adb
+++ gcc/ada/sem_res.adb
@@ -889,10 +889,7 @@ package body Sem_Res is
             Full_Type := T;
          end if;
 
-         if Is_Controlled (Full_Type) then
-            return False;
-
-         elsif Is_Array_Type (Full_Type) then
+         if Is_Array_Type (Full_Type) then
             return Uses_SS (Component_Type (Full_Type));
 
          elsif Is_Record_Type (Full_Type) then

Reply via email to