[Ada] Finer grained secondary stack management
Arnaud Charlet
charlet@adacore.com
Thu Apr 27 09:07:00 GMT 2017
This patch has several effects:
1) The management of the secondary stack is now "tighter". A transient block
created for the purpose of managing the secondary stack will do so unless
the block appears within a function returning on the secondary stack or when
2) is in effect. Previously, due to some questionable logic, the management
was left to the nearest enclosing scoping construct and not the block even
though the block was created to manage the secondary stack in the first
place.
2) Switch -gnatd.s now controls an optimization where a transient block created
for the purpose of managing the secondary stack will no longer manage the
secondary stack when there is an enclosing scoping construct which already
does so.
------------
-- Source --
------------
-- pack.ads
package Pack is
type Truth_Array is array (Positive range <>) of Boolean;
procedure Diagnose_Truth (Val : Truth_Array);
function Diagnose_Truth (Val : Truth_Array) return Boolean;
function Invert_Truth (Val : Truth_Array) return Truth_Array;
function Is_All_False (Val : Truth_Array) return Boolean;
function Is_All_True (Val : Truth_Array) return Boolean;
function Is_Gray_Area (Val : Truth_Array) return Boolean;
function Make_Truth (Ts : Natural; Fs : Natural) return Truth_Array;
end Pack;
-- pack.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Pack is
procedure Diagnose_Truth (Val : Truth_Array) is
begin
if Is_All_False (Val) then
Put_Line (" it is all lies");
elsif Is_All_True (Val) then
Put_Line (" it is all true");
elsif Is_Gray_Area (Val) then
Put_Line (" 50 shades of gray");
else
Put_Line (" truth not found");
end if;
end Diagnose_Truth;
function Diagnose_Truth (Val : Truth_Array) return Boolean is
begin
Diagnose_Truth (Val);
return True;
end Diagnose_Truth;
function Invert_Truth (Val : Truth_Array) return Truth_Array is
Result : Truth_Array := Val;
begin
for Index in Result'Range loop
Result (Index) := not Val (Index);
end loop;
return Result;
end Invert_Truth;
function Is_All_False (Val : Truth_Array) return Boolean is
Has_True : Boolean := False;
Is_Empty : Boolean := True;
begin
for Index in Val'Range loop
Is_Empty := False;
if Val (Index) then
Has_True := True;
exit;
end if;
end loop;
return not Is_Empty and not Has_True;
end Is_All_False;
function Is_All_True (Val : Truth_Array) return Boolean is
Has_False : Boolean := False;
Is_Empty : Boolean := True;
begin
for Index in Val'Range loop
Is_Empty := False;
if not Val (Index) then
Has_False := True;
exit;
end if;
end loop;
return not Is_Empty and not Has_False;
end Is_All_True;
function Is_Gray_Area (Val : Truth_Array) return Boolean is
Has_False : Boolean := False;
Has_True : Boolean := False;
Is_Empty : Boolean := True;
begin
for Index in Val'Range loop
Is_Empty := False;
if Val (Index) then
Has_True := True;
else
Has_False := True;
end if;
end loop;
return not Is_Empty and Has_False and Has_True;
end Is_Gray_Area;
function Make_Truth (Ts : Natural; Fs : Natural) return Truth_Array is
Result : Truth_Array (1 .. Ts + Fs) := (others => False);
begin
for Index in 1 .. Ts loop
Result (Index) := True;
end loop;
return Result;
end Make_Truth;
end Pack;
-- optimization.adb
with Ada.Text_IO; use Ada.Text_IO;
with Pack; use Pack;
pragma Warnings (Off);
with System.Secondary_Stack; use System.Secondary_Stack;
pragma Warnings (On);
procedure Optimization is
procedure Leaks (Val : Boolean) is
Obj : constant Truth_Array := Make_Truth (100_000, 0);
begin
if Val then
Diagnose_Truth (Invert_Truth (Make_Truth (0, 100_000)));
end if;
end Leaks;
SS_Before : constant Mark_Id := SS_Mark;
begin
Leaks (True);
if SS_Mark = SS_Before then
Put_Line ("OK");
else
Put_Line ("ERROR: secondary stack not reclaimed");
end if;
end Optimization;
----------------------------
-- Compilation and output -- (only relevant parts shown)
----------------------------
$ gnatmake -q -f -gnatG -gnatdI optimization.adb
$ ./optimization
$ gnatmake -q -f -gnatG -gnatdI optimization.adb -gnatd.s
$ ./optimization
procedure optimization__leaks (val : boolean) is
M...b : constant system__secondary_stack__mark_id :=
$system__secondary_stack__ss_mark;
procedure optimization__leaks___finalizer;
procedure optimization__leaks___finalizer is
begin
$system__secondary_stack__ss_release (M...b);
return;
end optimization__leaks___finalizer;
begin
type optimization__leaks__A...b is access all pack__truth_array;
R...b : constant optimization__leaks__A...b := pack__make_truth (
100000, 0)'reference;
B...b : constant integer := R...b.all'first(1);
B...b : constant integer := R...b.all'last(1);
subtype optimization__leaks__TobjS is pack__truth_array (B...b ..
B...b);
[constraint_error when
B...b >= B...b and then (B...b < 1)
"range check failed"]
obj : pack__truth_array renames R...b.all;
if val then
B...b : declare
M...b : constant system__secondary_stack__mark_id :=
$system__secondary_stack__ss_mark;
procedure optimization__leaks__B...b___finalizer;
procedure optimization__leaks__B...b___finalizer is
begin
$system__secondary_stack__ss_release (M...b);
return;
end optimization__leaks__B...b___finalizer;
begin
pack__diagnose_truth (pack__invert_truth (pack__make_truth
(0, 100000)));
at end
optimization__leaks__B...b___finalizer;
end B...b;
end if;
return;
at end
optimization__leaks___finalizer;
end optimization__leaks;
it is all true
OK
procedure optimization__leaks (val : boolean) is
M...b : constant system__secondary_stack__mark_id :=
$system__secondary_stack__ss_mark;
procedure optimization__leaks___finalizer;
procedure optimization__leaks___finalizer is
begin
$system__secondary_stack__ss_release (M...b);
return;
end optimization__leaks___finalizer;
begin
type optimization__leaks__A...b is access all pack__truth_array;
R...b : constant optimization__leaks__A...b := pack__make_truth (
100000, 0)'reference;
B...b : constant integer := R...b.all'first(1);
B...b : constant integer := R...b.all'last(1);
subtype optimization__leaks__TobjS is pack__truth_array (B...b ..
B...b);
[constraint_error when
B...b >= B...b and then (B...b < 1)
"range check failed"]
obj : pack__truth_array renames R...b.all;
if val then
B...b : declare
begin
pack__diagnose_truth (pack__invert_truth (pack__make_truth
(0, 100000)));
end B...b;
end if;
return;
at end
optimization__leaks___finalizer;
end optimization__leaks;
it is all true
OK
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* debug.adb: Document the use of switch -gnatd.s.
* einfo.ads Update the documentation on attribute
Sec_Stack_Needed_For_Return and attribute Uses_Sec_Stack. Remove
the uses of these attributes from certain entities.
* exp_ch7.adb (Make_Transient_Block): Reimplement the circuitry
which determines whether the block should continue to manage
the secondary stack.
(Manages_Sec_Stack): New routine.
-------------- next part --------------
Index: debug.adb
===================================================================
--- debug.adb (revision 247293)
+++ debug.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -109,7 +109,7 @@
-- d.p Use original Ada 95 semantics for Bit_Order (disable AI95-0133)
-- d.q Suppress optimizations on imported 'in'
-- d.r Enable OK_To_Reorder_Components in non-variant records
- -- d.s
+ -- d.s Minimize secondary stack Mark and Release calls
-- d.t Disable static allocation of library level dispatch tables
-- d.u Enable Modify_Tree_For_C (update tree for c)
-- d.v Enable OK_To_Reorder_Components in variant records
@@ -572,6 +572,11 @@
-- d.r Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have no discriminants.
+ -- d.s The compiler does not generate calls to secondary stack management
+ -- routines SS_Mark and SS_Release for a transient block when there is
+ -- an enclosing scoping construct which already manages the secondary
+ -- stack.
+
-- d.t The compiler has been modified (a fairly extensive modification)
-- to generate static dispatch tables for library level tagged types.
-- This debug switch disables this modification and reverts to the
Index: einfo.ads
===================================================================
--- einfo.ads (revision 247293)
+++ einfo.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -4163,10 +4163,10 @@
-- needed, since returns an invalid value in this case.
-- Sec_Stack_Needed_For_Return (Flag167)
--- Defined in scope entities (blocks, functions, procedures, tasks,
--- entries). Set to True when secondary stack is used to hold the
--- returned value of a function and thus should not be released on
--- scope exit.
+-- Defined in scope entities (blocks, entries, entry families, functions,
+-- and procedures). Set to True when secondary stack is used to hold the
+-- returned value of a function and thus should not be released on scope
+-- exit.
-- Shadow_Entities (List14)
-- Defined in package and generic package entities. Points to a list
@@ -4522,9 +4522,10 @@
-- Protection object (see System.Tasking.Protected_Objects).
-- Uses_Sec_Stack (Flag95)
--- Defined in scope entities (block, entry, function, loop, procedure,
--- task). Set to True when secondary stack is used in this scope and must
--- be released on exit unless Sec_Stack_Needed_For_Return is set.
+-- Defined in scope entities (blocks, entries, entry families, functions,
+-- loops, and procedures). Set to True when the secondary stack is used
+-- in this scope and must be released on exit unless flag
+-- Sec_Stack_Needed_For_Return is set.
-- Validated_Object (Node36)
-- Defined in variables. Contains the object whose value is captured by
@@ -6442,11 +6443,9 @@
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- Sec_Stack_Needed_For_Return (Flag167) ???
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
-- Uses_Lock_Free (Flag188)
- -- Uses_Sec_Stack (Flag95) ???
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- Has_Entries (synth)
@@ -6597,10 +6596,8 @@
-- Has_Master_Entity (Flag21)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- Sec_Stack_Needed_For_Return (Flag167) ???
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
- -- Uses_Sec_Stack (Flag95) ???
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- Has_Entries (synth)
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 247293)
+++ exp_ch7.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -8266,83 +8266,115 @@
Action : Node_Id;
Par : Node_Id) return Node_Id
is
- Decls : constant List_Id := New_List;
- Instrs : constant List_Id := New_List (Action);
+ function Manages_Sec_Stack (Id : Entity_Id) return Boolean;
+ -- Determine whether scoping entity Id manages the secondary stack
+
+ -----------------------
+ -- Manages_Sec_Stack --
+ -----------------------
+
+ function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
+ begin
+ -- An exception handler with a choice parameter utilizes a dummy
+ -- block to provide a declarative region. Such a block should not be
+ -- considered because it never manifests in the tree and can never
+ -- release the secondary stack.
+
+ if Ekind (Id) = E_Block
+ and then Uses_Sec_Stack (Id)
+ and then not Is_Exception_Handler (Id)
+ then
+ return True;
+
+ -- Loops are intentionally excluded because they undergo special
+ -- treatment, see Establish_Transient_Scope.
+
+ elsif Ekind_In (Id, E_Entry,
+ E_Entry_Family,
+ E_Function,
+ E_Procedure)
+ and then Uses_Sec_Stack (Id)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Manages_Sec_Stack;
+
+ -- Local variables
+
+ Decls : constant List_Id := New_List;
+ Instrs : constant List_Id := New_List (Action);
+ Trans_Id : constant Entity_Id := Current_Scope;
+
Block : Node_Id;
Insert : Node_Id;
+ Scop : Entity_Id;
+ -- Start of processing for Make_Transient_Block
+
begin
- -- Case where only secondary stack use is involved
+ -- Even though the transient block is tasked with managing the secondary
+ -- stack, the block may forgo this functionality depending on how the
+ -- secondary stack is managed by enclosing scopes.
- if Uses_Sec_Stack (Current_Scope)
- and then Nkind (Action) /= N_Simple_Return_Statement
- and then Nkind (Par) /= N_Exception_Handler
- then
- declare
- S : Entity_Id;
+ if Manages_Sec_Stack (Trans_Id) then
- begin
- S := Scope (Current_Scope);
- loop
- -- At the outer level, no need to release the sec stack
+ -- Determine whether an enclosing scope already manages the secondary
+ -- stack.
- if S = Standard_Standard then
- Set_Uses_Sec_Stack (Current_Scope, False);
- exit;
+ Scop := Scope (Trans_Id);
+ while Present (Scop) loop
+ if Scop = Standard_Standard then
+ exit;
- -- In a function, only release the sec stack if the function
- -- does not return on the sec stack otherwise the result may
- -- be lost. The caller is responsible for releasing.
+ -- The transient block must manage the secondary stack when the
+ -- block appears within a loop in order to reclaim the memory at
+ -- each iteration.
- elsif Ekind (S) = E_Function then
- Set_Uses_Sec_Stack (Current_Scope, False);
+ elsif Ekind (Scop) = E_Loop then
+ exit;
- if not Requires_Transient_Scope (Etype (S)) then
- Set_Uses_Sec_Stack (S, True);
- Check_Restriction (No_Secondary_Stack, Action);
- end if;
+ -- The transient block is within a function which returns on the
+ -- secondary stack. Take a conservative approach and assume that
+ -- the value on the secondary stack is part of the result. Note
+ -- that it is not possible to detect this dependency without flow
+ -- analysis which the compiler does not have. Letting the object
+ -- live longer than the transient block will not leak any memory
+ -- because the caller will reclaim the total storage used by the
+ -- function.
- exit;
+ elsif Ekind (Scop) = E_Function
+ and then Sec_Stack_Needed_For_Return (Scop)
+ then
+ Set_Uses_Sec_Stack (Trans_Id, False);
+ exit;
- -- In a loop or entry we should install a block encompassing
- -- all the construct. For now just release right away.
+ -- When requested, the transient block does not need to manage the
+ -- secondary stack when there exists an enclosing block, entry,
+ -- entry family, function, or a procedure which already does that.
+ -- This optimization saves on SS_Mark and SS_Release calls but may
+ -- allow objects to live a little longer than required.
- elsif Ekind_In (S, E_Entry, E_Loop) then
- exit;
+ elsif Debug_Flag_Dot_S and then Manages_Sec_Stack (Scop) then
+ Set_Uses_Sec_Stack (Trans_Id, False);
+ exit;
+ end if;
- -- 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.
-
- -- ??? 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);
- exit;
-
- else
- S := Scope (S);
- end if;
- end loop;
- end;
+ Scop := Scope (Scop);
+ end loop;
end if;
-- Create the transient block. Set the parent now since the block itself
- -- is not part of the tree. The current scope is the E_Block entity
- -- that has been pushed by Establish_Transient_Scope.
+ -- is not part of the tree. The current scope is the E_Block entity that
+ -- has been pushed by Establish_Transient_Scope.
- pragma Assert (Ekind (Current_Scope) = E_Block);
+ pragma Assert (Ekind (Trans_Id) = E_Block);
+
Block :=
Make_Block_Statement (Loc,
- Identifier => New_Occurrence_Of (Current_Scope, Loc),
+ Identifier => New_Occurrence_Of (Trans_Id, Loc),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
@@ -8357,8 +8389,9 @@
(Action, Clean => False, Manage_SS => False);
Insert := Prev (Action);
+
if Present (Insert) then
- Freeze_All (First_Entity (Current_Scope), Insert);
+ Freeze_All (First_Entity (Trans_Id), Insert);
end if;
-- Transfer cleanup actions to the newly created block
More information about the Gcc-patches
mailing list