[Ada] Leak with function returning String in exception handler
Arnaud Charlet
charlet@adacore.com
Wed Apr 20 10:46:00 GMT 2016
This patch modifies the transient scope mechanism to ignore blocks generated
for exception handlers with a choice parameter when propagating secondary stack
information up the scope stack. Such blocks are not physically present in the
tree and can never release the secondary stack on exit.
------------
-- Source --
------------
-- memory_leak.adb
procedure Memory_Leak is
function My_String return String is
begin
return "Foo";
end My_String;
begin
for I in 1 .. 100_000 loop
begin
raise Program_Error;
exception
when E : others =>
if My_String = "Bar" then
raise;
end if;
end;
end loop;
end Memory_Leak;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q memory_leak.adb -largs -lgmem
$ ./memory_leak
$ gnatmem ./memory_leak > output.txt
$ grep "Total number of" output.txt
Total number of allocations :100000
Total number of deallocations :100000
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb Flag286 is now used as Is_Exception_Handler.
(Is_Exception_Handler): New routine.
(Set_Is_Exception_Handler): New routine.
(Write_Entity_Flags): Output the status of Is_Exception_Handler.
* einfo.ads New attribute Is_Exception_Handler along with
occurrences in entities.
(Is_Exception_Handler): New routine along with pragma Inline.
(Set_Is_Exception_Handler): New routine along with pragma Inline.
* exp_ch7.adb (Make_Transient_Block): Ignore blocks generated
for exception handlers with a choice parameter.
* sem_ch11.adb (Analyze_Exception_Handlers): Mark the scope
generated for a choice parameter as an exception handler.
-------------- next part --------------
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 235258)
+++ exp_ch7.adb (working copy)
@@ -7993,14 +7993,22 @@
elsif Ekind_In (S, E_Entry, E_Loop) then
exit;
- -- In a procedure or a block, we release on exit of the
- -- procedure or block. ??? memory leak can be created by
- -- recursive calls.
+ -- In a procedure or a block, release the sec stack on exit
+ -- from the construct. Note that an exception handler with a
+ -- choice parameter requires a declarative region in the form
+ -- of a block. The block does not physically manifest in the
+ -- tree as it only serves as a scope. Do not consider such a
+ -- block because it will never release the sec stack.
- elsif Ekind_In (S, E_Block, E_Procedure) then
+ -- ??? Memory leak can be created by recursive calls
+
+ elsif Ekind (S) = E_Procedure
+ or else (Ekind (S) = E_Block
+ and then not Is_Exception_Handler (S))
+ then
+ Set_Uses_Sec_Stack (Current_Scope, False);
Set_Uses_Sec_Stack (S, True);
Check_Restriction (No_Secondary_Stack, Action);
- Set_Uses_Sec_Stack (Current_Scope, False);
exit;
else
Index: einfo.adb
===================================================================
--- einfo.adb (revision 235248)
+++ einfo.adb (working copy)
@@ -597,7 +597,7 @@
-- Is_Uplevel_Referenced_Entity Flag283
-- Is_Unimplemented Flag284
-- Is_Volatile_Full_Access Flag285
- -- (unused) Flag286
+ -- Is_Exception_Handler Flag286
-- Rewritten_For_C Flag287
-- (unused) Flag288
@@ -1976,12 +1976,6 @@
return Flag146 (Id);
end Is_Abstract_Type;
- function Is_Local_Anonymous_Access (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag194 (Id);
- end Is_Local_Anonymous_Access;
-
function Is_Access_Constant (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
@@ -2137,6 +2131,12 @@
return Flag52 (Id);
end Is_Entry_Formal;
+ function Is_Exception_Handler (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Block);
+ return Flag286 (Id);
+ end Is_Exception_Handler;
+
function Is_Exported (Id : E) return B is
begin
return Flag99 (Id);
@@ -2307,6 +2307,12 @@
return Flag25 (Id);
end Is_Limited_Record;
+ function Is_Local_Anonymous_Access (Id : E) return B is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Flag194 (Id);
+ end Is_Local_Anonymous_Access;
+
function Is_Machine_Code_Subprogram (Id : E) return B is
begin
pragma Assert (Is_Subprogram (Id));
@@ -5146,6 +5152,12 @@
Set_Flag52 (Id, V);
end Set_Is_Entry_Formal;
+ procedure Set_Is_Exception_Handler (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Block);
+ Set_Flag286 (Id, V);
+ end Set_Is_Exception_Handler;
+
procedure Set_Is_Exported (Id : E; V : B := True) is
begin
Set_Flag99 (Id, V);
@@ -8956,6 +8968,7 @@
W ("Is_Dispatching_Operation", Flag6 (Id));
W ("Is_Eliminated", Flag124 (Id));
W ("Is_Entry_Formal", Flag52 (Id));
+ W ("Is_Exception_Handler", Flag286 (Id));
W ("Is_Exported", Flag99 (Id));
W ("Is_First_Subtype", Flag70 (Id));
W ("Is_For_Access_Subtype", Flag118 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 235244)
+++ einfo.ads (working copy)
@@ -2428,6 +2428,11 @@
-- Is_Enumeration_Type (synthesized)
-- Defined in all entities, true for enumeration types and subtypes
+-- Is_Exception_Handler (Flag286)
+-- Defined in blocks. Set if the block serves only as a scope of an
+-- exception handler with a choice parameter. Such a block does not
+-- physically appear in the tree.
+
-- Is_Exported (Flag99)
-- Defined in all entities. Set if the entity is exported. For now we
-- only allow the export of constants, exceptions, functions, procedures
@@ -5621,6 +5626,7 @@
-- Discard_Names (Flag88)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
+ -- Is_Exception_Handler (Flag286)
-- Sec_Stack_Needed_For_Return (Flag167)
-- Uses_Sec_Stack (Flag95)
-- Scope_Depth (synth)
@@ -6971,6 +6977,7 @@
function Is_Dispatching_Operation (Id : E) return B;
function Is_Eliminated (Id : E) return B;
function Is_Entry_Formal (Id : E) return B;
+ function Is_Exception_Handler (Id : E) return B;
function Is_Exported (Id : E) return B;
function Is_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B;
@@ -7634,6 +7641,7 @@
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
procedure Set_Is_Eliminated (Id : E; V : B := True);
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
+ procedure Set_Is_Exception_Handler (Id : E; V : B := True);
procedure Set_Is_Exported (Id : E; V : B := True);
procedure Set_Is_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True);
@@ -8434,6 +8442,7 @@
pragma Inline (Is_Entry);
pragma Inline (Is_Entry_Formal);
pragma Inline (Is_Enumeration_Type);
+ pragma Inline (Is_Exception_Handler);
pragma Inline (Is_Exported);
pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type);
@@ -8923,6 +8932,7 @@
pragma Inline (Set_Is_Dispatching_Operation);
pragma Inline (Set_Is_Eliminated);
pragma Inline (Set_Is_Entry_Formal);
+ pragma Inline (Set_Is_Exception_Handler);
pragma Inline (Set_Is_Exported);
pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype);
Index: sem_ch11.adb
===================================================================
--- sem_ch11.adb (revision 235192)
+++ sem_ch11.adb (working copy)
@@ -214,6 +214,7 @@
H_Scope :=
New_Internal_Entity
(E_Block, Current_Scope, Sloc (Choice), 'E');
+ Set_Is_Exception_Handler (H_Scope);
end if;
Push_Scope (H_Scope);
@@ -318,11 +319,11 @@
N_Formal_Package_Declaration
then
Error_Msg_NE
- ("exception& is declared in " &
- "generic formal package", Id, Ent);
+ ("exception& is declared in generic formal "
+ & "package", Id, Ent);
Error_Msg_N
- ("\and therefore cannot appear in " &
- "handler (RM 11.2(8))", Id);
+ ("\and therefore cannot appear in handler "
+ & "(RM 11.2(8))", Id);
exit;
-- If the exception is declared in an inner
@@ -362,8 +363,8 @@
Analyze_Statements (Statements (Handler));
- -- If a choice was present, we created a special scope for it,
- -- so this is where we pop that special scope to get rid of it.
+ -- If a choice was present, we created a special scope for it, so
+ -- this is where we pop that special scope to get rid of it.
if Present (Choice) then
End_Scope;
More information about the Gcc-patches
mailing list