This patch modifies the way Max_Size_In_Storage_Elements operates when applied
to a controlled type. The attribute returns the size of the prefix plus the
size of the two hidden pointer which are added by the runtime support for
controlled objects on the heap.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-11-21 Hristian Kirtchev <kirtc...@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, case
Max_Size_In_Storage_Elements): Account for the size of the
hidden list header which precedes controlled objects allocated
on the heap.
* rtsfind.ads: Add RE_Header_Size_With_Padding to the runtime
tables.
* sinfo.adb (Header_Size_Added): New routine.
(Set_Header_Size_Added): New routine.
* sinfo.ads: Add flag Controlled_Header_Added along with
associated comment.
(Header_Size_Added): New inlined routine.
(Set_Header_Size_Added): New inlined routine.
* s-stposu.adb (Allocate_Any_Controlled): Use
Header_Size_With_Padding to calculate the proper
size of the header.
(Deallocate_Any_Controlled): Use
Header_Size_With_Padding to calculate the proper size
of the header. (Header_Size_With_Padding): New routine.
(Nearest_Multiple_Rounded_Up): Removed along with its uses.
* s-stposu.ads (Header_Size_With_Padding): New routine.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 181574)
+++ exp_attr.adb (working copy)
@@ -2989,6 +2989,52 @@
Analyze_And_Resolve (N, Typ);
end Mantissa;
+ ----------------------------------
+ -- Max_Size_In_Storage_Elements --
+ ----------------------------------
+
+ when Attribute_Max_Size_In_Storage_Elements =>
+ Apply_Universal_Integer_Attribute_Checks (N);
+
+ -- Heap-allocated controlled objects contain two extra pointers which
+ -- are not part of the actual type. Transform the attribute reference
+ -- into a runtime expression to add the size of the hidden header.
+
+ -- Do not perform this expansion on .NET/JVM targets because the
+ -- two pointers are already present in the type.
+
+ if VM_Target = No_VM
+ and then Nkind (N) = N_Attribute_Reference
+ and then Needs_Finalization (Ptyp)
+ and then not Header_Size_Added (N)
+ then
+ Set_Header_Size_Added (N);
+
+ -- Generate:
+ -- P'Max_Size_In_Storage_Elements +
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (Ptyp'Alignment))
+
+ Rewrite (N,
+ Make_Op_Add (Loc,
+ Left_Opnd => Relocate_Node (N),
+ Right_Opnd =>
+ Convert_To (Universal_Integer,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (RTE (RE_Header_Size_With_Padding), Loc),
+
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Ptyp, Loc),
+ Attribute_Name => Name_Alignment))))));
+
+ Analyze (N);
+ return;
+ end if;
+
--------------------
-- Mechanism_Code --
--------------------
@@ -5572,8 +5618,7 @@
-- that the result is in range.
when Attribute_Aft |
- Attribute_Max_Alignment_For_Allocation |
- Attribute_Max_Size_In_Storage_Elements =>
+ Attribute_Max_Alignment_For_Allocation =>
Apply_Universal_Integer_Attribute_Checks (N);
-- The following attributes should not appear at this stage, since they
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 181575)
+++ sinfo.adb (working copy)
@@ -1573,6 +1573,14 @@
return Flag13 (N);
end Has_Wide_Wide_Character;
+ function Header_Size_Added
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference);
+ return Flag11 (N);
+ end Header_Size_Added;
+
function Hidden_By_Use_Clause
(N : Node_Id) return Elist_Id is
begin
@@ -4637,6 +4645,14 @@
Set_Flag13 (N, Val);
end Set_Has_Wide_Wide_Character;
+ procedure Set_Header_Size_Added
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Reference);
+ Set_Flag11 (N, Val);
+ end Set_Header_Size_Added;
+
procedure Set_Hidden_By_Use_Clause
(N : Node_Id; Val : Elist_Id) is
begin
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 181575)
+++ sinfo.ads (working copy)
@@ -1205,6 +1205,13 @@
-- code outside the Wide_Character range) appears in the string. Used to
-- implement pragma preference rules.
+ -- Header_Size_Added (Flag11-Sem)
+ -- Present in N_Attribute_Reference nodes, set only for attribute
+ -- Max_Size_In_Storage_Elements. The flag indicates that the size of the
+ -- hidden list header used by the runtime finalization support has been
+ -- added to the size of the prefix. The flag also prevents the infinite
+ -- expansion of the same attribute in the said context.
+
-- Hidden_By_Use_Clause (Elist4-Sem)
-- An entity list present in use clauses that appear within
-- instantiations. For the resolution of local entities, entities
@@ -3326,6 +3333,7 @@
-- Entity (Node4-Sem) used if the attribute yields a type
-- Associated_Node (Node4-Sem)
-- Do_Overflow_Check (Flag17-Sem)
+ -- Header_Size_Added (Flag11-Sem)
-- Redundant_Use (Flag13-Sem)
-- Must_Be_Byte_Aligned (Flag14)
-- plus fields for expression
@@ -8555,6 +8563,9 @@
function Has_Wide_Wide_Character
(N : Node_Id) return Boolean; -- Flag13
+ function Header_Size_Added
+ (N : Node_Id) return Boolean; -- Flag11
+
function Hidden_By_Use_Clause
(N : Node_Id) return Elist_Id; -- Elist4
@@ -9530,6 +9541,9 @@
procedure Set_Has_Wide_Wide_Character
(N : Node_Id; Val : Boolean := True); -- Flag13
+ procedure Set_Header_Size_Added
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
procedure Set_Hidden_By_Use_Clause
(N : Node_Id; Val : Elist_Id); -- Elist4
@@ -11926,6 +11940,7 @@
pragma Inline (Has_Task_Name_Pragma);
pragma Inline (Has_Wide_Character);
pragma Inline (Has_Wide_Wide_Character);
+ pragma Inline (Header_Size_Added);
pragma Inline (Hidden_By_Use_Clause);
pragma Inline (High_Bound);
pragma Inline (Identifier);
@@ -12247,6 +12262,7 @@
pragma Inline (Set_Has_Task_Name_Pragma);
pragma Inline (Set_Has_Wide_Character);
pragma Inline (Set_Has_Wide_Wide_Character);
+ pragma Inline (Set_Header_Size_Added);
pragma Inline (Set_Hidden_By_Use_Clause);
pragma Inline (Set_High_Bound);
pragma Inline (Set_Identifier);
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 181574)
+++ rtsfind.ads (working copy)
@@ -1353,6 +1353,7 @@
RE_Allocate_Any_Controlled, -- System.Storage_Pools.Subpools
RE_Deallocate_Any_Controlled, -- System.Storage_Pools.Subpools
+ RE_Header_Size_With_Padding, -- System.Storage_Pools.Subpools
RE_Root_Storage_Pool_With_Subpools, -- System.Storage_Pools.Subpools
RE_Root_Subpool, -- System.Storage_Pools.Subpools
RE_Subpool_Handle, -- System.Storage_Pools.Subpools
@@ -2550,6 +2551,7 @@
RE_Allocate_Any_Controlled => System_Storage_Pools_Subpools,
RE_Deallocate_Any_Controlled => System_Storage_Pools_Subpools,
+ RE_Header_Size_With_Padding => System_Storage_Pools_Subpools,
RE_Root_Storage_Pool_With_Subpools => System_Storage_Pools_Subpools,
RE_Root_Subpool => System_Storage_Pools_Subpools,
RE_Subpool_Handle => System_Storage_Pools_Subpools,
Index: s-stposu.adb
===================================================================
--- s-stposu.adb (revision 181574)
+++ s-stposu.adb (working copy)
@@ -56,12 +56,6 @@
procedure Detach (N : not null SP_Node_Ptr);
-- Unhook a subpool node from an arbitrary subpool list
- function Nearest_Multiple_Rounded_Up
- (Size : Storage_Count;
- Alignment : Storage_Count) return Storage_Count;
- -- Given arbitrary values of storage size and alignment, calculate the
- -- nearest multiple of the alignment rounded up where size can fit.
-
--------------
-- Allocate --
--------------
@@ -218,10 +212,7 @@
-- Account for possible padding space before the header due to a
-- larger alignment.
- Header_And_Padding :=
- Nearest_Multiple_Rounded_Up
- (Size => Header_Size,
- Alignment => Alignment);
+ Header_And_Padding := Header_Size_With_Padding (Alignment);
N_Size := Storage_Size + Header_And_Padding;
@@ -388,10 +379,7 @@
-- Account for possible padding space before the header due to a
-- larger alignment.
- Header_And_Padding :=
- Nearest_Multiple_Rounded_Up
- (Size => Header_Size,
- Alignment => Alignment);
+ Header_And_Padding := Header_Size_With_Padding (Alignment);
-- N_Addr N_Ptr Addr (from input)
-- | | |
@@ -571,6 +559,28 @@
Free (Subpool.Node);
end Finalize_Subpool;
+ ------------------------------
+ -- Header_Size_With_Padding --
+ ------------------------------
+
+ function Header_Size_With_Padding
+ (Alignment : System.Storage_Elements.Storage_Count)
+ return System.Storage_Elements.Storage_Count
+ is
+ Size : constant Storage_Count := Header_Size;
+
+ begin
+ if Size mod Alignment = 0 then
+ return Size;
+
+ -- Add enough padding to reach the nearest multiple of the alignment
+ -- rounding up.
+
+ else
+ return ((Size + Alignment - 1) / Alignment) * Alignment;
+ end if;
+ end Header_Size_With_Padding;
+
----------------
-- Initialize --
----------------
@@ -592,26 +602,6 @@
Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
end Initialize_Pool;
- ---------------------------------
- -- Nearest_Multiple_Rounded_Up --
- ---------------------------------
-
- function Nearest_Multiple_Rounded_Up
- (Size : Storage_Count;
- Alignment : Storage_Count) return Storage_Count
- is
- begin
- if Size mod Alignment = 0 then
- return Size;
-
- -- Add enough padding to reach the nearest multiple of the alignment
- -- rounding up.
-
- else
- return ((Size + Alignment - 1) / Alignment) * Alignment;
- end if;
- end Nearest_Multiple_Rounded_Up;
-
---------------------
-- Pool_Of_Subpool --
---------------------
Index: s-stposu.ads
===================================================================
--- s-stposu.ads (revision 181574)
+++ s-stposu.ads (working copy)
@@ -329,6 +329,13 @@
-- subpool from its owner's list. Deallocate the associated doubly linked
-- list node.
+ function Header_Size_With_Padding
+ (Alignment : System.Storage_Elements.Storage_Count)
+ return System.Storage_Elements.Storage_Count;
+ -- Given an arbitrary alignment, calculate the size of the header which
+ -- precedes a controlled object as the nearest multiple rounded up of the
+ -- alignment.
+
overriding procedure Initialize (Controller : in out Pool_Controller);
-- Buffer routine, calls Initialize_Pool
