git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* a-fihema.ads, a-fihema.adb: Unit removed.
	* a-undesu.ads, a-undesu.adb: New unit implementing
	Ada.Unchecked_Deallocate_Subpool.
	* einfo.adb: Remove Associated_Collection from the node usage.
	Add Finalization_Master to the node usage.
	(Associated_Collection): Removed.
	(Finalization_Master): New routine.
	(Set_Associated_Collection): Removed.
	(Set_Finalization_Master): New routine.
	(Write_Field23_Name): Remove Associated_Collection from the output. Add
	Finalization_Master to the output.
	* einfo.ads: Remove attribute Associated_Collection and its uses in
	entities.
	Add new attribute Finalization_Master along with its uses in entitites.
	(Associated_Collection): Removed along with its pragma import.
	(Finalization_Master): New routine along with a pragma import.
	(Set_Associated_Collection): Removed along with its pragma import.
	(Set_Finalization_Master): New routine along with a pragma import.
	* exp_ch3.adb (Expand_Freeze_Array_Type): Replace call to
	Build_Finalization_Collection with Build_Finalization_Master.
	(Expand_Freeze_Record_Type): Move the generation of Finalize_Address
	before the bodies of the predefined routines. Add comment explaining
	this. Replace call to Build_Finalization_Collection with
	Build_Finalization_Master.
	(Freeze_Type): Replace call to Build_Finalization_Collection with
	Build_Finalization_Master.
	(Make_Finalize_Address_Body): Comment reformatting.
	(Make_Predefined_Primitive_Specs): Code reformatting.
	(Stream_Operation_OK): Update comment mentioning finalization
	collections. Replace RE_Finalization_Collection with
	RE_Finalization_Master.
	* exp_ch4.adb (Complete_Controlled_Allocation): Replace call to
	Associated_Collection with Finalization_Master. Replace call to
	Build_Finalization_Collection with Build_Finalization_Master.
	(Expand_Allocator_Expression): Replace call to Associated_Collection
	with Finalization_Master. Replace call to Set_Associated_Collection with
	Set_Finalization_Master. Remove the generation of
	Set_Finalize_Address_Ptr.
	(Expand_N_Allocator): Replace call to Associated_Collection with
	Finalization_Master. Remove the generation of Set_Finalize_Address_Ptr.
	* exp_ch6.adb (Add_Collection_Actual_To_Build_In_Place_Call): Renamed to
	Add_Finalization_Master_Actual_To_Build_In_Place_Call. Update the
	comment on usage. Replace call to Needs_BIP_Collection with
	Needs_BIP_Finalization_Master Remplace BIP_Collection with
	BIP_Finalization_Master. Update all comments which mention finalization
	collections. Replace Associated_Collection with
	Finalization_Master. Replace Build_Finalization_Collection with
	Build_Finalization_Master.
	(BIP_Formal_Suffix): Update BIP_Collection's case.
	(Build_Heap_Allocator): Update the related comment. Rename local
	variable Collect to Fin_Mas_Id and update its occurrences. Update
	comments which mention finalization collections. Replace
	Set_Associated_Collection with Set_Finalization_Master.
	(Expand_Call): Update the code which detects a special piece of library
	code for .NET/JVM.
	(Make_Build_In_Place_Call_In_Allocator): Replace the call to
	Add_Collection_Actual_To_Build_In_Place_Call with
	Add_Finalization_Master_Actual_To_Build_In_Place_Call. Remove the code
	which generates a call to Make_Set_Finalize_Address_Ptr_Call.
	(Make_Build_In_Place_Call_In_Anonymous_Context): Replace call to
	Add_Collection_Actual_To_Build_In_Place_Call with
	Add_Finalization_Master_Actual_To_Build_In_Place_Call.
	(Make_Build_In_Place_Call_In_Assignment): Replace call to
	Add_Collection_Actual_To_Build_In_Place_Call with
	Add_Finalization_Master_Actual_To_Build_In_Place_Call.
	(Needs_BIP_Collection): Renamed to Needs_BIP_Finalization_Master.
	* exp_ch6.ads: Rename BIP_Collection to BIP_Finalization_Master.
	(Needs_BIP_Collection): Renamed to Needs_BIP_Finalization_Master.
	* exp_ch7.adb (Build_BIP_Cleanup_Stmts): Update comment on usage.
	Rename local variable Collect to Fin_Mas_Id and update its occurrences.
	Replace call to Set_Associated_Collection with Set_Finalization_Master.
	(Build_Finalization_Collection): Renamed to Build_Finalization_Master.
	Replace the call to Associated_Collection with Finalization_Master.
	Rename local variable Coll_Id to Fin_Mas_Id and update its occurrences.
	Update the way finalization master names are generated. Update the
	retrieval of the correct access type which will carry the pool and
	master attributes.
	(Make_Final_Call): Reimplement the way [Deep_]Finalize is retrieved.
	(Make_Finalize_Address_Body): Abstract types do not need
	Finalize_Address. Code reformatting.
	(Make_Finalize_Address_Stmts): Update comment on usage.
	(Make_Set_Finalize_Address_Ptr_Call): Removed.
	(Process_Declarations): Update comments.
	* exp_ch7.ads (Build_Finalization_Collection): Renamed to
	Build_Finalization_Master. Update associated comment.
	(Make_Set_Finalize_Address_Ptr_Call): Removed.
	* exp_ch13.adb: Update comments which mention finalization collections.
	(Expand_N_Free_Statement): Replace the call to Associated_Collection
	with Finalization_Master.
	* exp_util.adb (Build_Allocate_Deallocate_Proc): Reimplemented to
	create calls to routines Allocate_Any_Controlled and
	Deallocate_Any_Controlled.
	(Find_Finalize_Address): New routine.
	(Is_Allocate_Deallocate_Proc): Update the RTE entities used in the
	comparison.
	(Requires_Cleanup_Actions): Update the comment on freeze node
	inspection.
	* exp_util.ads: Remove comment on generated code for
	Build_Allocate_Deallocate_Proc. The code is now quite complex and it
	is better to simply look in the body.
	* freeze.adb (Freeze_All): Update the comment of finalization
	collections. Replace the call to Associated_Collection with
	Finalization_Master. Replace the call to Build_Finalization_Collection
	with Build_Finalization_Master.
	* impunit.adb: Add a-undesu and s-stposu to the list of units.
	* Makefile.rtl: Add files a-undesu, s-finmas and s-stposu. Remove file
	a-fihema.
	* rtsfind.adb (Get_Unit_Name): Remove the processing for children of
	Ada.Finalization. Add processing for children of System.Storage_Pools.
	* rtsfind.ads: Remove the naming of second level children of
	Ada.Finalization.
	Remove Ada_Finalization_Heap_Management from the list of units.
	Remove subtype Ada_Finalization_Child.
	Remove the following subprogram entities:
	
	   RE_Allocate
	   RE_Deallocate
	   RE_Finalization_Collection
	   RE_Finalization_Collection_Ptr
	   RE_Set_Finalize_Address_Ptr
	
	Add the naming of second level children of System.Storage_Pools.
	Add System_Finalization_Masters and System_Storage_Pools_Subpools to
	the list of units.
	Add subtype System_Storage_Pools_Child.
	Add the following subprogram entities to System.Finalization_Masters:
	
	   RE_Finalization_Master
	   RE_Finalization_Master_Ptr
	
	Add the following subprogram entities to System.Storage_Pools.Subpools:
	
	   RE_Allocate_Any_Controlled
	   RE_Deallocate_Any_Controlled
	   RE_Root_Storage_Pool_With_Subpools
	   RE_Root_Subpool
	   RE_Subpool_Handle
	
	Move the following subprogram entities from
	Ada.Finalization.Heap_Management to System.Finalization_Masters:
	
	   RE_Add_Offset_To_Address
	   RE_Attach
	   RE_Base_Pool
	   RE_Detach
	
	* sem_ch3.adb (Access_Type_Declaration): Replace the call to
	Set_Associated_Collection with Set_Finalization_Master.
	* sem_ch6.adb (Create_Extra_Formals): Update the way extra formal
	BIP_Finalization_Master is created.
	* s-finmas.adb: New unit System.Finalization_Masters.
	* s-finmas.ads: New unit System.Finalization_Masters.
	* s-stopoo.ads, s-stopoo.adb: Minor code reformatting.
	* s-stposu.ads, s-stposu.adb: New unit implementing
	System.Storage_Pools.Subpools.

2011-08-29  Bob Duff  <duff@adacore.com>

	* tbuild.adb: Add assertion.

From-SVN: r178183
This commit is contained in:
Arnaud Charlet 2011-08-29 11:52:57 +02:00
parent 8c889ae483
commit d3f70b35df
30 changed files with 1920 additions and 1404 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
gcc/ada/ChangeLog
View File

@ -1,3 +1,165 @@
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* a-fihema.ads, a-fihema.adb: Unit removed.
* a-undesu.ads, a-undesu.adb: New unit implementing
Ada.Unchecked_Deallocate_Subpool.
* einfo.adb: Remove Associated_Collection from the node usage.
Add Finalization_Master to the node usage.
(Associated_Collection): Removed.
(Finalization_Master): New routine.
(Set_Associated_Collection): Removed.
(Set_Finalization_Master): New routine.
(Write_Field23_Name): Remove Associated_Collection from the output. Add
Finalization_Master to the output.
* einfo.ads: Remove attribute Associated_Collection and its uses in
entities.
Add new attribute Finalization_Master along with its uses in entitites.
(Associated_Collection): Removed along with its pragma import.
(Finalization_Master): New routine along with a pragma import.
(Set_Associated_Collection): Removed along with its pragma import.
(Set_Finalization_Master): New routine along with a pragma import.
* exp_ch3.adb (Expand_Freeze_Array_Type): Replace call to
Build_Finalization_Collection with Build_Finalization_Master.
(Expand_Freeze_Record_Type): Move the generation of Finalize_Address
before the bodies of the predefined routines. Add comment explaining
this. Replace call to Build_Finalization_Collection with
Build_Finalization_Master.
(Freeze_Type): Replace call to Build_Finalization_Collection with
Build_Finalization_Master.
(Make_Finalize_Address_Body): Comment reformatting.
(Make_Predefined_Primitive_Specs): Code reformatting.
(Stream_Operation_OK): Update comment mentioning finalization
collections. Replace RE_Finalization_Collection with
RE_Finalization_Master.
* exp_ch4.adb (Complete_Controlled_Allocation): Replace call to
Associated_Collection with Finalization_Master. Replace call to
Build_Finalization_Collection with Build_Finalization_Master.
(Expand_Allocator_Expression): Replace call to Associated_Collection
with Finalization_Master. Replace call to Set_Associated_Collection with
Set_Finalization_Master. Remove the generation of
Set_Finalize_Address_Ptr.
(Expand_N_Allocator): Replace call to Associated_Collection with
Finalization_Master. Remove the generation of Set_Finalize_Address_Ptr.
* exp_ch6.adb (Add_Collection_Actual_To_Build_In_Place_Call): Renamed to
Add_Finalization_Master_Actual_To_Build_In_Place_Call. Update the
comment on usage. Replace call to Needs_BIP_Collection with
Needs_BIP_Finalization_Master Remplace BIP_Collection with
BIP_Finalization_Master. Update all comments which mention finalization
collections. Replace Associated_Collection with
Finalization_Master. Replace Build_Finalization_Collection with
Build_Finalization_Master.
(BIP_Formal_Suffix): Update BIP_Collection's case.
(Build_Heap_Allocator): Update the related comment. Rename local
variable Collect to Fin_Mas_Id and update its occurrences. Update
comments which mention finalization collections. Replace
Set_Associated_Collection with Set_Finalization_Master.
(Expand_Call): Update the code which detects a special piece of library
code for .NET/JVM.
(Make_Build_In_Place_Call_In_Allocator): Replace the call to
Add_Collection_Actual_To_Build_In_Place_Call with
Add_Finalization_Master_Actual_To_Build_In_Place_Call. Remove the code
which generates a call to Make_Set_Finalize_Address_Ptr_Call.
(Make_Build_In_Place_Call_In_Anonymous_Context): Replace call to
Add_Collection_Actual_To_Build_In_Place_Call with
Add_Finalization_Master_Actual_To_Build_In_Place_Call.
(Make_Build_In_Place_Call_In_Assignment): Replace call to
Add_Collection_Actual_To_Build_In_Place_Call with
Add_Finalization_Master_Actual_To_Build_In_Place_Call.
(Needs_BIP_Collection): Renamed to Needs_BIP_Finalization_Master.
* exp_ch6.ads: Rename BIP_Collection to BIP_Finalization_Master.
(Needs_BIP_Collection): Renamed to Needs_BIP_Finalization_Master.
* exp_ch7.adb (Build_BIP_Cleanup_Stmts): Update comment on usage.
Rename local variable Collect to Fin_Mas_Id and update its occurrences.
Replace call to Set_Associated_Collection with Set_Finalization_Master.
(Build_Finalization_Collection): Renamed to Build_Finalization_Master.
Replace the call to Associated_Collection with Finalization_Master.
Rename local variable Coll_Id to Fin_Mas_Id and update its occurrences.
Update the way finalization master names are generated. Update the
retrieval of the correct access type which will carry the pool and
master attributes.
(Make_Final_Call): Reimplement the way [Deep_]Finalize is retrieved.
(Make_Finalize_Address_Body): Abstract types do not need
Finalize_Address. Code reformatting.
(Make_Finalize_Address_Stmts): Update comment on usage.
(Make_Set_Finalize_Address_Ptr_Call): Removed.
(Process_Declarations): Update comments.
* exp_ch7.ads (Build_Finalization_Collection): Renamed to
Build_Finalization_Master. Update associated comment.
(Make_Set_Finalize_Address_Ptr_Call): Removed.
* exp_ch13.adb: Update comments which mention finalization collections.
(Expand_N_Free_Statement): Replace the call to Associated_Collection
with Finalization_Master.
* exp_util.adb (Build_Allocate_Deallocate_Proc): Reimplemented to
create calls to routines Allocate_Any_Controlled and
Deallocate_Any_Controlled.
(Find_Finalize_Address): New routine.
(Is_Allocate_Deallocate_Proc): Update the RTE entities used in the
comparison.
(Requires_Cleanup_Actions): Update the comment on freeze node
inspection.
* exp_util.ads: Remove comment on generated code for
Build_Allocate_Deallocate_Proc. The code is now quite complex and it
is better to simply look in the body.
* freeze.adb (Freeze_All): Update the comment of finalization
collections. Replace the call to Associated_Collection with
Finalization_Master. Replace the call to Build_Finalization_Collection
with Build_Finalization_Master.
* impunit.adb: Add a-undesu and s-stposu to the list of units.
* Makefile.rtl: Add files a-undesu, s-finmas and s-stposu. Remove file
a-fihema.
* rtsfind.adb (Get_Unit_Name): Remove the processing for children of
Ada.Finalization. Add processing for children of System.Storage_Pools.
* rtsfind.ads: Remove the naming of second level children of
Ada.Finalization.
Remove Ada_Finalization_Heap_Management from the list of units.
Remove subtype Ada_Finalization_Child.
Remove the following subprogram entities:
RE_Allocate
RE_Deallocate
RE_Finalization_Collection
RE_Finalization_Collection_Ptr
RE_Set_Finalize_Address_Ptr
Add the naming of second level children of System.Storage_Pools.
Add System_Finalization_Masters and System_Storage_Pools_Subpools to
the list of units.
Add subtype System_Storage_Pools_Child.
Add the following subprogram entities to System.Finalization_Masters:
RE_Finalization_Master
RE_Finalization_Master_Ptr
Add the following subprogram entities to System.Storage_Pools.Subpools:
RE_Allocate_Any_Controlled
RE_Deallocate_Any_Controlled
RE_Root_Storage_Pool_With_Subpools
RE_Root_Subpool
RE_Subpool_Handle
Move the following subprogram entities from
Ada.Finalization.Heap_Management to System.Finalization_Masters:
RE_Add_Offset_To_Address
RE_Attach
RE_Base_Pool
RE_Detach
* sem_ch3.adb (Access_Type_Declaration): Replace the call to
Set_Associated_Collection with Set_Finalization_Master.
* sem_ch6.adb (Create_Extra_Formals): Update the way extra formal
BIP_Finalization_Master is created.
* s-finmas.adb: New unit System.Finalization_Masters.
* s-finmas.ads: New unit System.Finalization_Masters.
* s-stopoo.ads, s-stopoo.adb: Minor code reformatting.
* s-stposu.ads, s-stposu.adb: New unit implementing
System.Storage_Pools.Subpools.
2011-08-29 Bob Duff <duff@adacore.com>
* tbuild.adb: Add assertion.
2011-08-29 Thomas Quinot <quinot@adacore.com>
* s-pooglo.adb: Minor reformatting.

4
gcc/ada/Makefile.rtl
View File

@ -154,7 +154,6 @@ GNATRTL_NONTASKING_OBJS= \
a-envvar$(objext) \
a-except$(objext) \
a-exctra$(objext) \
a-fihema$(objext) \
a-finali$(objext) \
a-flteio$(objext) \
a-fwteio$(objext) \
@ -290,6 +289,7 @@ GNATRTL_NONTASKING_OBJS= \
a-tiunio$(objext) \
a-unccon$(objext) \
a-uncdea$(objext) \
a-undesu$(objext) \
a-wichha$(objext) \
a-wichun$(objext) \
a-widcha$(objext) \
@ -495,6 +495,7 @@ GNATRTL_NONTASKING_OBJS= \
s-ficobl$(objext) \
s-fileio$(objext) \
s-filofl$(objext) \
s-finmas$(objext) \
s-finroo$(objext) \
s-fishfl$(objext) \
s-flocon$(objext) \
@ -611,6 +612,7 @@ GNATRTL_NONTASKING_OBJS= \
s-stchop$(objext) \
s-stoele$(objext) \
s-stopoo$(objext) \
s-stposu$(objext) \
s-stratt$(objext) \
s-strhas$(objext) \
s-string$(objext) \

568
gcc/ada/a-fihema.adb
View File

@ -1,568 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A D A . F I N A L I Z A T I O N . H E A P _ M A N A G E M E N T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2008-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
with System; use System;
with System.Address_Image;
with System.IO; use System.IO;
-- ???with System.OS_Lib;
-- Breaks ravenscar runtimes
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
with System.Storage_Pools; use System.Storage_Pools;
package body Ada.Finalization.Heap_Management is
Debug : constant Boolean := False;
-- True for debugging printouts.
Header_Size : constant Storage_Count := Node'Size / Storage_Unit;
-- Size of the header in bytes. Added to Storage_Size requested by
-- Allocate/Deallocate to determine the Storage_Size passed to the
-- underlying pool.
function Address_To_Node_Ptr is
new Ada.Unchecked_Conversion (Address, Node_Ptr);
procedure Attach (N : Node_Ptr; L : Node_Ptr);
-- Prepend a node to a list
procedure Detach (N : Node_Ptr);
-- Unhook a node from an arbitrary list
procedure Fin_Assert (Condition : Boolean; Message : String);
-- Asserts that the condition is True. Used instead of pragma Assert in
-- delicate places where raising an exception would cause re-invocation of
-- finalization. Instead of raising an exception, aborts the whole process.
function Is_Empty (Objects : Node_Ptr) return Boolean;
-- True if the Objects list is empty
----------------
-- Fin_Assert --
----------------
procedure Fin_Assert (Condition : Boolean; Message : String) is
procedure Fail;
-- Use a separate procedure to make it easy to set a breakpoint here.
----------
-- Fail --
----------
procedure Fail is
begin
Put_Line ("Heap_Management: Fin_Assert failed: " & Message);
-- ???OS_Lib.OS_Abort;
-- Breaks ravenscar runtimes
end Fail;
-- Start of processing for Fin_Assert
begin
if not Condition then
Fail;
end if;
end Fin_Assert;
---------------------------
-- Add_Offset_To_Address --
---------------------------
function Add_Offset_To_Address
(Addr : System.Address;
Offset : System.Storage_Elements.Storage_Offset) return System.Address
is
begin
return System.Storage_Elements."+" (Addr, Offset);
end Add_Offset_To_Address;
--------------
-- Allocate --
--------------
procedure Allocate
(Collection : in out Finalization_Collection;
Addr : out System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Needs_Header : Boolean := True)
is
begin
-- Allocation of an object with controlled parts
if Needs_Header then
-- Do not allow the allocation of controlled objects while the
-- associated collection is being finalized.
if Collection.Finalization_Started then
raise Program_Error with "allocation after finalization started";
end if;
declare
Header_Offset : Storage_Offset;
N_Addr : Address;
N_Ptr : Node_Ptr;
begin
-- Offset from the header to the actual object. The header is
-- just in front of the object. There may be padding space before
-- the header.
if Alignment > Header_Size then
Header_Offset := Alignment;
else
Header_Offset := Header_Size;
end if;
-- Use the underlying pool to allocate enough space for the object
-- and the list header. The returned address points to the list
-- header. If locking is necessary, it will be done by the
-- underlying pool.
Allocate
(Collection.Base_Pool.all,
N_Addr,
Storage_Size + Header_Offset,
Alignment);
-- Map the allocated memory into a Node record. This converts the
-- top of the allocated bits into a list header.
N_Ptr := Address_To_Node_Ptr
(N_Addr + Header_Offset - Header_Size);
Attach (N_Ptr, Collection.Objects'Unchecked_Access);
-- Move the address from Prev to the start of the object. This
-- operation effectively hides the list header.
Addr := N_Addr + Header_Offset;
end;
-- Allocation of a non-controlled object
else
Allocate
(Collection.Base_Pool.all,
Addr,
Storage_Size,
Alignment);
end if;
pragma Assert (Addr mod Alignment = 0);
end Allocate;
------------
-- Attach --
------------
procedure Attach (N : Node_Ptr; L : Node_Ptr) is
begin
Lock_Task.all;
L.Next.Prev := N;
N.Next := L.Next;
L.Next := N;
N.Prev := L;
Unlock_Task.all;
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
end Attach;
---------------
-- Base_Pool --
---------------
function Base_Pool
(Collection : Finalization_Collection) return Any_Storage_Pool_Ptr
is
begin
return Collection.Base_Pool;
end Base_Pool;
----------------
-- Deallocate --
----------------
procedure Deallocate
(Collection : in out Finalization_Collection;
Addr : System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Has_Header : Boolean := True)
is
pragma Assert (Addr mod Alignment = 0);
begin
-- Deallocation of an object with controlled parts
if Has_Header then
declare
Header_Offset : Storage_Offset;
N_Addr : Address;
N_Ptr : Node_Ptr;
begin
-- Offset from the header to the actual object.
if Alignment > Header_Size then
Header_Offset := Alignment;
else
Header_Offset := Header_Size;
end if;
-- Converts from the object to the list header
N_Ptr := Address_To_Node_Ptr (Addr - Header_Size);
Detach (N_Ptr);
-- Converts the bits preceding the object the block address.
N_Addr := Addr - Header_Offset;
-- Use the underlying pool to destroy the object along with the
-- list header.
Deallocate
(Collection.Base_Pool.all,
N_Addr,
Storage_Size + Header_Size,
Alignment);
end;
-- Deallocation of a non-controlled object
else
Deallocate
(Collection.Base_Pool.all,
Addr,
Storage_Size,
Alignment);
end if;
end Deallocate;
------------
-- Detach --
------------
procedure Detach (N : Node_Ptr) is
begin
pragma Debug (Fin_Assert (N /= null, "Detach null"));
Lock_Task.all;
if N.Next = null then
pragma Assert (N.Prev = null);
else
N.Prev.Next := N.Next;
N.Next.Prev := N.Prev;
N.Next := null;
N.Prev := null;
end if;
Unlock_Task.all;
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
end Detach;
--------------
-- Finalize --
--------------
overriding procedure Finalize
(Collection : in out Finalization_Collection)
is
Ex_Occur : Exception_Occurrence;
Raised : Boolean := False;
begin
if Debug then
Put_Line ("-->Heap_Management: ");
pcol (Collection);
end if;
-- Set Finalization_Started to prevent any allocations of objects with
-- controlled parts during finalization. The associated access type is
-- about to go out of scope; Finalization_Started is never again
-- modified.
if Collection.Finalization_Started then
-- ???Needed for shared libraries
return;
end if;
pragma Debug (Fin_Assert (not Collection.Finalization_Started,
"Finalize: already started"));
Collection.Finalization_Started := True;
-- For each object in the Objects list, detach it, and finalize it. Note
-- that other tasks can be doing Unchecked_Deallocations at the same
-- time, so we need to beware of race conditions.
while not Is_Empty (Collection.Objects'Unchecked_Access) loop
declare
Node : constant Node_Ptr := Collection.Objects.Next;
begin
-- Remove the current node from the list first, in case some other
-- task is simultaneously doing Unchecked_Deallocation on this
-- object. Detach does Lock_Task. Note that we can't Lock_Task
-- during Finalize_Address, because finalization can do pretty
-- much anything.
Detach (Node);
-- ??? Kludge: Don't do anything until the proper place to set
-- primitive Finalize_Address has been determined.
if Collection.Finalize_Address /= null then
declare
Object_Address : constant Address :=
Node.all'Address + Header_Size;
-- Get address of object from address of header
begin
Collection.Finalize_Address (Object_Address);
exception
when Fin_Except : others =>
if not Raised then
Raised := True;
Save_Occurrence (Ex_Occur, Fin_Except);
end if;
end;
end if;
end;
end loop;
if Debug then
Put_Line ("<--Heap_Management: ");
pcol (Collection);
end if;
-- If the finalization of a particular node raised an exception, reraise
-- it after the remainder of the list has been finalized.
if Raised then
if Debug then
Put_Line ("Heap_Management: reraised");
end if;
Reraise_Occurrence (Ex_Occur);
end if;
end Finalize;
----------------
-- Initialize --
----------------
overriding procedure Initialize
(Collection : in out Finalization_Collection)
is
begin
-- The dummy head must point to itself in both directions
Collection.Objects.Next := Collection.Objects'Unchecked_Access;
Collection.Objects.Prev := Collection.Objects'Unchecked_Access;
pragma Assert (Is_Empty (Collection.Objects'Unchecked_Access));
end Initialize;
--------------
-- Is_Empty --
--------------
function Is_Empty (Objects : Node_Ptr) return Boolean is
begin
pragma Debug
(Fin_Assert ((Objects.Next = Objects) = (Objects.Prev = Objects),
"Is_Empty"));
return Objects.Next = Objects;
end Is_Empty;
----------
-- pcol --
----------
procedure pcol (Collection : Finalization_Collection) is
Head : constant Node_Ptr := Collection.Objects'Unrestricted_Access;
-- "Unrestricted", because we are getting access-to-variable of a
-- constant! Normally worrisome, this is OK for debugging code.
Head_Seen : Boolean := False;
N_Ptr : Node_Ptr;
begin
-- Output the basic contents of the collection
-- Collection: 0x123456789
-- Base_Pool : null <or> 0x123456789
-- Fin_Addr : null <or> 0x123456789
-- Fin_Start : TRUE <or> FALSE
Put ("Collection: ");
Put_Line (Address_Image (Collection'Address));
Put ("Base_Pool : ");
if Collection.Base_Pool = null then
Put_Line (" null");
else
Put_Line (Address_Image (Collection.Base_Pool'Address));
end if;
Put ("Fin_Addr : ");
if Collection.Finalize_Address = null then
Put_Line ("null");
else
Put_Line (Address_Image (Collection.Finalize_Address'Address));
end if;
Put ("Fin_Start : ");
Put_Line (Collection.Finalization_Started'Img);
-- Output all chained elements. The format is the following:
-- ^ <or> ? <or> null
-- |Header: 0x123456789 (dummy head)
-- | Prev: 0x123456789
-- | Next: 0x123456789
-- V
-- ^ - the current element points back to the correct element
-- ? - the current element points back to an erroneous element
-- n - the current element points back to null
-- Header - the address of the list header
-- Prev - the address of the list header which the current element
-- - points back to
-- Next - the address of the list header which the current element
-- - points to
-- (dummy head) - present if dummy head
N_Ptr := Head;
while N_Ptr /= null loop -- Should never be null; we being defensive
Put_Line ("V");
-- We see the head initially; we want to exit when we see the head a
-- SECOND time.
if N_Ptr = Head then
exit when Head_Seen;
Head_Seen := True;
end if;
-- The current element is null. This should never happen since the
-- list is circular.
if N_Ptr.Prev = null then
Put_Line ("null (ERROR)");
-- The current element points back to the correct element
elsif N_Ptr.Prev.Next = N_Ptr then
Put_Line ("^");
-- The current element points to an erroneous element
else
Put_Line ("? (ERROR)");
end if;
-- Output the header and fields
Put ("|Header: ");
Put (Address_Image (N_Ptr.all'Address));
-- Detect the dummy head
if N_Ptr = Head then
Put_Line (" (dummy head)");
else
Put_Line ("");
end if;
Put ("| Prev: ");
if N_Ptr.Prev = null then
Put_Line ("null");
else
Put_Line (Address_Image (N_Ptr.Prev.all'Address));
end if;
Put ("| Next: ");
if N_Ptr.Next = null then
Put_Line ("null");
else
Put_Line (Address_Image (N_Ptr.Next.all'Address));
end if;
N_Ptr := N_Ptr.Next;
end loop;
end pcol;
------------------------------
-- Set_Finalize_Address_Ptr --
------------------------------
procedure Set_Finalize_Address_Ptr
(Collection : in out Finalization_Collection;
Proc_Ptr : Finalize_Address_Ptr)
is
begin
Collection.Finalize_Address := Proc_Ptr;
end Set_Finalize_Address_Ptr;
--------------------------
-- Set_Storage_Pool_Ptr --
--------------------------
procedure Set_Storage_Pool_Ptr
(Collection : in out Finalization_Collection;
Pool_Ptr : Any_Storage_Pool_Ptr)
is
begin
Collection.Base_Pool := Pool_Ptr;
end Set_Storage_Pool_Ptr;
end Ada.Finalization.Heap_Management;

161
gcc/ada/a-fihema.ads
View File

@ -1,161 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A D A . F I N A L I Z A T I O N . H E A P _ M A N A G E M E N T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2008-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System;
with System.Storage_Elements;
with System.Storage_Pools;
package Ada.Finalization.Heap_Management is
-- A reference to any derivation of Root_Storage_Pool. Since this type may
-- not be used to allocate objects, its storage size is zero.
type Any_Storage_Pool_Ptr is
access System.Storage_Pools.Root_Storage_Pool'Class;
for Any_Storage_Pool_Ptr'Storage_Size use 0;
-- ??? Comment needed on overall mechanism
type Finalization_Collection is
new Ada.Finalization.Limited_Controlled with private;
type Finalization_Collection_Ptr is access all Finalization_Collection;
for Finalization_Collection_Ptr'Storage_Size use 0;
-- A reference used to describe primitive Finalize_Address
type Finalize_Address_Ptr is access procedure (Obj : System.Address);
-- Since RTSfind cannot contain names of the form RE_"+", the following
-- routine serves as a wrapper around System.Storage_Elements."+".
function Add_Offset_To_Address
(Addr : System.Address;
Offset : System.Storage_Elements.Storage_Offset) return System.Address;
procedure Allocate
(Collection : in out Finalization_Collection;
Addr : out System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Needs_Header : Boolean := True);
-- Allocate a chunk of memory described by Storage_Size and Alignment on
-- Collection's underlying storage pool. Return the address of the chunk.
-- The routine creates a list header which precedes the chunk of memory if
-- Needs_Header is True. If allocated, the header is attached to the
-- Collection's objects. The interface to this routine is provided by
-- Build_Allocate_Deallocate_Proc.
function Base_Pool
(Collection : Finalization_Collection) return Any_Storage_Pool_Ptr;
-- Return a reference to the underlying storage pool of Collection
procedure Deallocate
(Collection : in out Finalization_Collection;
Addr : System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Has_Header : Boolean := True);
-- Deallocate a chunk of memory described by Storage_Size and Alignment
-- from Collection's underlying storage pool. The beginning of the memory
-- chunk is designated by Addr. The routine detaches and destroys the
-- preceding list header if flag Has_Header is set. The interface to this
-- routine is provided by Build_Allocate_Deallocate_Proc.
overriding procedure Finalize
(Collection : in out Finalization_Collection);
-- Traverse objects of Collection, invoking Finalize_Address on each one
overriding procedure Initialize
(Collection : in out Finalization_Collection);
-- Initialize the finalization list to empty
procedure Set_Finalize_Address_Ptr
(Collection : in out Finalization_Collection;
Proc_Ptr : Finalize_Address_Ptr);
-- Set the finalization address routine of a finalization collection
procedure Set_Storage_Pool_Ptr
(Collection : in out Finalization_Collection;
Pool_Ptr : Any_Storage_Pool_Ptr);
-- Set the underlying storage pool of a finalization collection
private
-- Homogeneous collection types
type Node;
type Node_Ptr is access all Node;
pragma No_Strict_Aliasing (Node_Ptr);
-- The following record type should really be limited, but we can see the
-- full view of Limited_Controlled, which is NOT limited. Note that default
-- initialization does not happen for this type (the pointers will not be
-- automatically set to null), because of the games we're playing with
-- address arithmetic. Code in the body assumes that the size of
-- this record is a power of 2 to deal with alignment.
type Node is record
Prev : Node_Ptr;
Next : Node_Ptr;
end record;
type Finalization_Collection is
new Ada.Finalization.Limited_Controlled with
record
Base_Pool : Any_Storage_Pool_Ptr;
-- All objects and node headers are allocated on this underlying pool;
-- the collection is simply a wrapper around it.
Objects : aliased Node;
-- The head of a doubly linked list containing all allocated objects
-- with controlled parts that still exist (Unchecked_Deallocation has
-- not been done on them).
Finalize_Address : Finalize_Address_Ptr;
-- A reference to a routine that finalizes an object denoted by its
-- address. The collection must be homogeneous since the same routine
-- will be invoked for every allocated object when the pool is
-- finalized.
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- When the finalization of a collection takes place, any allocations of
-- objects with controlled or protected parts on the same collection are
-- prohibited and the action must raise Program_Error. This needs to be
-- atomic, because it is accessed without Lock_Task/Unlock_Task. See
-- RM-4.8(10.2/2).
end record;
procedure pcol (Collection : Finalization_Collection);
-- Output the contents of a collection in a readable form. Intended for
-- debugging purposes.
end Ada.Finalization.Heap_Management;

36
gcc/ada/a-undesu.adb Normal file
View File

@ -0,0 +1,36 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
-- ??? What is the header version here, see a-uncdea.adb. No GPL?
with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
procedure Ada.Unchecked_Deallocate_Subpool
(Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle)
is
begin
-- Finalize all controlled objects allocated on the input subpool
-- ??? It is awkward to create a child of Storage_Pools.Subpools for the
-- sole purpose of exporting Finalize_Subpool.
-- Finalize_Subpool (Subpool);
-- Dispatch to the user-defined implementation of Deallocate_Subpool
Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
end Ada.Unchecked_Deallocate_Subpool;

23
gcc/ada/a-undesu.ads Normal file
View File

@ -0,0 +1,23 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
-- ??? What is the header version here, see a-uncdea.ads. No GPL?
with System.Storage_Pools.Subpools;
procedure Ada.Unchecked_Deallocate_Subpool
(Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle);

42
gcc/ada/einfo.adb
View File

@ -195,11 +195,11 @@ package body Einfo is
-- Scope_Depth_Value Uint22
-- Shared_Var_Procs_Instance Node22
-- Associated_Collection Node23
-- CR_Discriminant Node23
-- Entry_Cancel_Parameter Node23
-- Enum_Pos_To_Rep Node23
-- Extra_Constrained Node23
-- Finalization_Master Node23
-- Generic_Renamings Elist23
-- Inner_Instances Elist23
-- Limited_View Node23
@ -612,12 +612,6 @@ package body Einfo is
return Uint14 (Id);
end Alignment;
function Associated_Collection (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
return Node23 (Id);
end Associated_Collection;
function Associated_Formal_Package (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Package);
@ -1075,6 +1069,12 @@ package body Einfo is
return Flag229 (Base_Type (Id));
end Can_Use_Internal_Rep;
function Finalization_Master (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
return Node23 (Root_Type (Id));
end Finalization_Master;
function Finalize_Storage_Only (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
@ -3051,12 +3051,6 @@ package body Einfo is
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
procedure Set_Associated_Collection (Id : E; V : E) is
begin
pragma Assert (Is_Access_Type (Id));
Set_Node23 (Id, V);
end Set_Associated_Collection;
procedure Set_Associated_Formal_Package (Id : E; V : E) is
begin
Set_Node12 (Id, V);
@ -3544,6 +3538,12 @@ package body Einfo is
Set_Flag229 (Id, V);
end Set_Can_Use_Internal_Rep;
procedure Set_Finalization_Master (Id : E; V : E) is
begin
pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
Set_Node23 (Id, V);
end Set_Finalization_Master;
procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
@ -6941,15 +6941,7 @@ package body Einfo is
if Ekind (T) = E_Class_Wide_Type then
return Etype (T);
elsif Ekind (T) = E_Class_Wide_Subtype then
return Etype (Base_Type (T));
-- ??? T comes from Base_Type, how can it be a subtype?
-- Also Base_Type is supposed to be idempotent, so either way
-- this is equivalent to "return Etype (T)" and should be merged
-- with the E_Class_Wide_Type case.
-- All other cases
-- Other cases
else
loop
@ -8459,9 +8451,6 @@ package body Einfo is
procedure Write_Field23_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Access_Kind =>
Write_Str ("Associated_Collection");
when E_Discriminant =>
Write_Str ("CR_Discriminant");
@ -8475,6 +8464,9 @@ package body Einfo is
E_Variable =>
Write_Str ("Extra_Constrained");
when Access_Kind =>
Write_Str ("Finalization_Master");
when E_Generic_Function |
E_Generic_Package |
E_Generic_Procedure =>

27
gcc/ada/einfo.ads
View File

@ -427,12 +427,6 @@ package Einfo is
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
-- Associated_Collection (Node23)
-- Present in non-subprogram access type entities. Contains the entity of
-- the finalization collection on which dynamically allocated objects
-- referenced by the access type are stored. Empty when the access type
-- cannot reference a controlled object.
-- Associated_Formal_Package (Node12)
-- Present in packages that are the actuals of formal_packages. Points
-- to the entity in the declaration for the formal package.
@ -1144,6 +1138,13 @@ package Einfo is
-- must be retrieved through the entity designed by this field instead of
-- being computed.
-- Finalization_Master (Node23) [root type only]
-- Present in access-to-controlled or access-to-class-wide types. The
-- field contains the entity of the finalization master which handles
-- dynamically allocated controlled objects referenced by the access
-- type. Empty for access-to-subprogram types. Empty for access types
-- whose designated type does not need finalization actions.
-- Finalize_Storage_Only (Flag158) [base type only]
-- Present in all types. Set on direct controlled types to which a
-- valid Finalize_Storage_Only pragma applies. This flag is also set on
@ -4943,7 +4944,7 @@ package Einfo is
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
-- Associated_Storage_Pool (Node22) (base type only)
-- Associated_Collection (Node23) (base type only)
-- Finalization_Master (Node23) (base type only)
-- Has_Pragma_Controlled (Flag27) (base type only)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Is_Access_Constant (Flag69)
@ -4971,7 +4972,7 @@ package Einfo is
-- E_Anonymous_Access_Type
-- Storage_Size_Variable (Node15) ??? is this needed ???
-- Directly_Designated_Type (Node20)
-- Associated_Collection (Node23)
-- Finalization_Master (Node23)
-- (plus type attributes)
-- E_Array_Type
@ -5278,7 +5279,7 @@ package Einfo is
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
-- Associated_Storage_Pool (Node22) (root type only)
-- Associated_Collection (Node23)
-- Finalization_Master (Node23) (root type only)
-- (plus type attributes)
-- E_Generic_In_Parameter
@ -5974,7 +5975,6 @@ package Einfo is
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
function Alignment (Id : E) return U;
function Associated_Collection (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
function Associated_Node_For_Itype (Id : E) return N;
function Associated_Storage_Pool (Id : E) return E;
@ -6050,6 +6050,7 @@ package Einfo is
function Extra_Formal (Id : E) return E;
function Extra_Formals (Id : E) return E;
function Can_Use_Internal_Rep (Id : E) return B;
function Finalization_Master (Id : E) return E;
function Finalize_Storage_Only (Id : E) return B;
function Finalizer (Id : E) return E;
function First_Entity (Id : E) return E;
@ -6563,7 +6564,6 @@ package Einfo is
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
procedure Set_Associated_Collection (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
procedure Set_Associated_Node_For_Itype (Id : E; V : N);
procedure Set_Associated_Storage_Pool (Id : E; V : E);
@ -6637,6 +6637,7 @@ package Einfo is
procedure Set_Extra_Formal (Id : E; V : E);
procedure Set_Extra_Formals (Id : E; V : E);
procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True);
procedure Set_Finalization_Master (Id : E; V : E);
procedure Set_Finalize_Storage_Only (Id : E; V : B := True);
procedure Set_Finalizer (Id : E; V : E);
procedure Set_First_Entity (Id : E; V : E);
@ -7259,7 +7260,6 @@ package Einfo is
pragma Inline (Address_Taken);
pragma Inline (Alias);
pragma Inline (Alignment);
pragma Inline (Associated_Collection);
pragma Inline (Associated_Formal_Package);
pragma Inline (Associated_Node_For_Itype);
pragma Inline (Associated_Storage_Pool);
@ -7335,6 +7335,7 @@ package Einfo is
pragma Inline (Extra_Formal);
pragma Inline (Extra_Formals);
pragma Inline (Can_Use_Internal_Rep);
pragma Inline (Finalization_Master);
pragma Inline (Finalizer);
pragma Inline (First_Entity);
pragma Inline (First_Exit_Statement);
@ -7703,7 +7704,6 @@ package Einfo is
pragma Inline (Set_Address_Taken);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
pragma Inline (Set_Associated_Collection);
pragma Inline (Set_Associated_Formal_Package);
pragma Inline (Set_Associated_Node_For_Itype);
pragma Inline (Set_Associated_Storage_Pool);
@ -7778,6 +7778,7 @@ package Einfo is
pragma Inline (Set_Extra_Formal);
pragma Inline (Set_Extra_Formals);
pragma Inline (Set_Can_Use_Internal_Rep);
pragma Inline (Set_Finalization_Master);
pragma Inline (Set_Finalizer);
pragma Inline (Set_First_Entity);
pragma Inline (Set_First_Exit_Statement);

8
gcc/ada/exp_ch13.adb
View File

@ -230,7 +230,7 @@ package body Exp_Ch13 is
return;
end if;
-- Use the base type to perform the collection check
-- Use the base type to perform the check for finalization master
Typ := Etype (Expr);
@ -248,10 +248,10 @@ package body Exp_Ch13 is
-- Do not create a custom Deallocate when freeing an object with
-- suppressed finalization. In such cases the object is never attached
-- to a collection, so it does not need to be detached. Use a regular
-- free statement instead.
-- to a master, so it does not need to be detached. Use a regular free
-- statement instead.
if No (Associated_Collection (Typ)) then
if No (Finalization_Master (Typ)) then
return;
end if;

41
gcc/ada/exp_ch3.adb
View File

@ -5482,12 +5482,13 @@ package body Exp_Ch3 is
Build_Slice_Assignment (Typ);
end if;
-- ??? This may not be necessary after all
-- ??? Now that masters acts as heterogeneous lists, it might be
-- worthed to revisit the global master approach.
elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
then
Build_Finalization_Collection (Comp_Typ);
Build_Finalization_Master (Comp_Typ);
end if;
end if;
@ -5581,8 +5582,8 @@ package body Exp_Ch3 is
return;
end if;
-- Generate the body of Finalize_Address. This routine is accessible
-- through the TSS mechanism.
-- Create the body of TSS primitive Finalize_Address. This automatically
-- sets the TSS entry for the class-wide type.
Make_Finalize_Address_Body (Typ);
end Expand_Freeze_Class_Wide_Type;
@ -6310,13 +6311,17 @@ package body Exp_Ch3 is
-- compiling a CPP tagged type.
elsif not Restriction_Active (No_Dispatching_Calls) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List);
-- Create the body of Finalize_Address, a helper routine used in
-- conjunction with controlled objects on the heap.
-- Create the body of TSS primitive Finalize_Address. This must
-- be done before the bodies of all predefined primitives are
-- created. If Def_Id is limited, Stream_Input and Streap_Read
-- may produce build-in-place allocations and for that the
-- expander needs Finalize_Address.
Make_Finalize_Address_Body (Def_Id);
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List);
end if;
-- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
@ -6364,7 +6369,7 @@ package body Exp_Ch3 is
and then Directly_Designated_Type (Comp_Typ) /= Def_Id
then
Build_Finalization_Collection
Build_Finalization_Master
(Typ => Comp_Typ,
Ins_Node => Parent (Def_Id),
Encl_Scope => Scope (Def_Id));
@ -6652,7 +6657,7 @@ package body Exp_Ch3 is
and then not Is_Frozen (Desig_Type)
and then Needs_Finalization (Component_Type (Desig_Type)))
then
Build_Finalization_Collection (Def_Id);
Build_Finalization_Master (Def_Id);
end if;
end;
@ -8399,7 +8404,7 @@ package body Exp_Ch3 is
end if;
-- All tagged types receive their own Deep_Adjust and Deep_Finalize
-- regardless of whether they are controlled or contain controlled
-- regardless of whether they are controlled or may contain controlled
-- components.
-- Do not generate the routines if finalization is disabled
@ -8414,12 +8419,10 @@ package body Exp_Ch3 is
else
if not Is_Limited_Type (Tag_Typ) then
Append_To (Res,
Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
end if;
Append_To (Res,
Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
end if;
Predef_List := Res;
@ -9028,9 +9031,9 @@ package body Exp_Ch3 is
-- to be (implicitly) inherited in that case because it can lead to a VM
-- exception.
-- Do not generate stream routines for type Finalization_Collection
-- because collection may never appear in types and therefore cannot be
-- read or written.
-- Do not generate stream routines for type Finalization_Master because
-- a master may never appear in types and therefore cannot be read or
-- written.
return
(not Is_Limited_Type (Typ)
@ -9053,7 +9056,7 @@ package body Exp_Ch3 is
and then RTE_Available (RE_Tag)
and then No (Type_Without_Stream_Operation (Typ))
and then RTE_Available (RE_Root_Stream_Type)
and then not Is_RTE (Typ, RE_Finalization_Collection);
and then not Is_RTE (Typ, RE_Finalization_Master);
end Stream_Operation_OK;
end Exp_Ch3;

94
gcc/ada/exp_ch4.adb
View File

@ -444,12 +444,15 @@ package body Exp_Ch4 is
return;
end if;
-- ??? Now that finalization masters act as heterogeneous lists, it
-- might be worthed to revisit the global master approach.
-- Processing for anonymous access-to-controlled types. These access
-- types receive a special collection which appears on the declarations
-- of the enclosing semantic unit.
-- types receive a special finalization master which appears in the
-- declarations of the enclosing semantic unit.
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Associated_Collection (Ptr_Typ))
and then No (Finalization_Master (Ptr_Typ))
and then
(not Restriction_Active (No_Nested_Finalization)
or else Is_Library_Level_Entity (Ptr_Typ))
@ -466,7 +469,7 @@ package body Exp_Ch4 is
Scop := Corresponding_Spec (Parent (Parent (Parent (Scop))));
end if;
Build_Finalization_Collection
Build_Finalization_Master
(Typ => Ptr_Typ,
Ins_Node => First_Declaration_Of_Current_Unit,
Encl_Scope => Scop);
@ -481,7 +484,7 @@ package body Exp_Ch4 is
-- Since the temporary object reuses the original allocator, generate a
-- custom Allocate routine for the temporary.
if Present (Associated_Collection (Ptr_Typ)) then
if Present (Finalization_Master (Ptr_Typ)) then
Build_Allocate_Deallocate_Proc
(N => Temp_Decl,
Is_Allocate => True);
@ -858,14 +861,14 @@ package body Exp_Ch4 is
Complete_Controlled_Allocation (Temp_Decl);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
-- Attach the object to the associated finalization collection.
-- Attach the object to the associated finalization master.
-- This is done manually on .NET/JVM since those compilers do
-- no support pools and can't benefit from internally generated
-- Allocate / Deallocate procedures.
if VM_Target /= No_VM
and then Is_Controlled (DesigT)
and then Present (Associated_Collection (PtrT))
and then Present (Finalization_Master (PtrT))
then
Insert_Action (N,
Make_Attach_Call (
@ -888,14 +891,14 @@ package body Exp_Ch4 is
Insert_Action (N, Temp_Decl);
Complete_Controlled_Allocation (Temp_Decl);
-- Attach the object to the associated finalization collection.
-- Attach the object to the associated finalization master.
-- This is done manually on .NET/JVM since those compilers do
-- no support pools and can't benefit from internally generated
-- Allocate / Deallocate procedures.
if VM_Target /= No_VM
and then Is_Controlled (DesigT)
and then Present (Associated_Collection (PtrT))
and then Present (Finalization_Master (PtrT))
then
Insert_Action (N,
Make_Attach_Call (
@ -931,8 +934,7 @@ package body Exp_Ch4 is
-- Inherit the allocation-related attributes from the original
-- access type.
Set_Associated_Collection (Def_Id,
Associated_Collection (PtrT));
Set_Finalization_Master (Def_Id, Finalization_Master (PtrT));
Set_Associated_Storage_Pool (Def_Id,
Associated_Storage_Pool (PtrT));
@ -1083,25 +1085,6 @@ package body Exp_Ch4 is
Prefix => New_Reference_To (Temp, Loc))),
Typ => T));
end if;
-- Generate:
-- Set_Finalize_Address_Ptr
-- (Collection, <Finalize_Address>'Unrestricted_Access)
-- Since .NET/JVM compilers do not support address arithmetic,
-- this call is skipped. The same is done for CodePeer because
-- Finalize_Address is never generated.
if VM_Target = No_VM
and then not CodePeer_Mode
and then Present (Associated_Collection (PtrT))
then
Insert_Action (N,
Make_Set_Finalize_Address_Ptr_Call
(Loc => Loc,
Typ => T,
Ptr_Typ => PtrT));
end if;
end if;
Rewrite (N, New_Reference_To (Temp, Loc));
@ -1139,14 +1122,14 @@ package body Exp_Ch4 is
Complete_Controlled_Allocation (Temp_Decl);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
-- Attach the object to the associated finalization collection. This
-- is done manually on .NET/JVM since those compilers do no support
-- Attach the object to the associated finalization master. Thisis
-- done manually on .NET/JVM since those compilers do no support
-- pools and cannot benefit from internally generated Allocate and
-- Deallocate procedures.
if VM_Target /= No_VM
and then Is_Controlled (DesigT)
and then Present (Associated_Collection (PtrT))
and then Present (Finalization_Master (PtrT))
then
Insert_Action (N,
Make_Attach_Call
@ -3564,7 +3547,7 @@ package body Exp_Ch4 is
-- do not support pools, this step is skipped.
if VM_Target = No_VM
and then Present (Associated_Collection (PtrT))
and then Present (Finalization_Master (PtrT))
then
Build_Allocate_Deallocate_Proc
(N => Parent (N),
@ -3858,39 +3841,22 @@ package body Exp_Ch4 is
(Obj_Ref => New_Copy_Tree (Init_Arg1),
Typ => T));
if Present (Associated_Collection (PtrT)) then
-- Special processing for .NET/JVM, the allocated object is
-- attached to the finalization master. Generate:
-- Special processing for .NET/JVM, the allocated object
-- is attached to the finalization collection. Generate:
-- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
-- Attach (<PtrT>FC, Root_Controlled_Ptr (Init_Arg1));
-- Types derived from [Limited_]Controlled are the only
-- ones considered since they have fields Prev and Next.
-- Types derived from [Limited_]Controlled are the only
-- ones considered since they have fields Prev and Next.
if VM_Target /= No_VM then
if Is_Controlled (T) then
Insert_Action (N,
Make_Attach_Call
(Obj_Ref => New_Copy_Tree (Init_Arg1),
Ptr_Typ => PtrT));
end if;
-- Default case, generate:
-- Set_Finalize_Address_Ptr
-- (Pool, <Finalize_Address>'Unrestricted_Access)
-- Do not generate the above for CodePeer compilations
-- because Finalize_Address is never built.
elsif not CodePeer_Mode then
Insert_Action (N,
Make_Set_Finalize_Address_Ptr_Call
(Loc => Loc,
Typ => T,
Ptr_Typ => PtrT));
end if;
if VM_Target /= No_VM
and then Present (Finalization_Master (PtrT))
and then Is_Controlled (T)
then
Insert_Action (N,
Make_Attach_Call
(Obj_Ref => New_Copy_Tree (Init_Arg1),
Ptr_Typ => PtrT));
end if;
end if;

161
gcc/ada/exp_ch6.adb
View File

@ -110,14 +110,14 @@ package body Exp_Ch6 is
-- Adds Extra_Actual as a named parameter association for the formal
-- Extra_Formal in Subprogram_Call.
procedure Add_Collection_Actual_To_Build_In_Place_Call
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty);
-- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs
-- finalization actions, add an actual parameter which is a pointer to the
-- finalization collection of the caller. If Ptr_Typ is left Empty, this
-- will result in an automatic "null" value for the actual.
-- finalization master of the caller. If Ptr_Typ is left Empty, this will
-- result in an automatic "null" value for the actual.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
@ -340,30 +340,30 @@ package body Exp_Ch6 is
(Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
end Add_Alloc_Form_Actual_To_Build_In_Place_Call;
--------------------------------------------------
-- Add_Collection_Actual_To_Build_In_Place_Call --
--------------------------------------------------
-----------------------------------------------------------
-- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
-----------------------------------------------------------
procedure Add_Collection_Actual_To_Build_In_Place_Call
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty)
is
begin
if not Needs_BIP_Collection (Func_Id) then
if not Needs_BIP_Finalization_Master (Func_Id) then
return;
end if;
declare
Formal : constant Entity_Id :=
Build_In_Place_Formal (Func_Id, BIP_Collection);
Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
Loc : constant Source_Ptr := Sloc (Func_Call);
Actual : Node_Id;
Desig_Typ : Entity_Id;
begin
-- Case where the context does not require an actual collection
-- Case where the context does not require an actual master
if No (Ptr_Typ) then
Actual := Make_Null (Loc);
@ -372,9 +372,9 @@ package body Exp_Ch6 is
Desig_Typ := Directly_Designated_Type (Ptr_Typ);
-- Check for a library-level access type whose designated type has
-- supressed finalization. Such an access types lack a collection.
-- supressed finalization. Such an access types lack a master.
-- Pass a null actual to the callee in order to signal a missing
-- collection.
-- master.
if Is_Library_Level_Entity (Ptr_Typ)
and then Finalize_Storage_Only (Desig_Typ)
@ -385,28 +385,28 @@ package body Exp_Ch6 is
elsif Needs_Finalization (Desig_Typ) then
-- The general mechanism of creating finalization collections
-- for anonymous access types is disabled by default, otherwise
-- collections will pop all over the place. Such types use
-- context-specific collections.
-- The general mechanism of creating finalization masters for
-- anonymous access types is disabled by default, otherwise
-- finalization masters will pop all over the place. Such types
-- use context-specific masters.
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Associated_Collection (Ptr_Typ))
and then No (Finalization_Master (Ptr_Typ))
then
Build_Finalization_Collection
Build_Finalization_Master
(Typ => Ptr_Typ,
Ins_Node => Associated_Node_For_Itype (Ptr_Typ),
Encl_Scope => Scope (Ptr_Typ));
end if;
-- Access-to-controlled types should always have a collection
-- Access-to-controlled types should always have a master
pragma Assert (Present (Associated_Collection (Ptr_Typ)));
pragma Assert (Present (Finalization_Master (Ptr_Typ)));
Actual :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
Attribute_Name => Name_Unrestricted_Access);
-- Tagged types
@ -423,7 +423,7 @@ package body Exp_Ch6 is
Add_Extra_Actual_To_Call (Func_Call, Formal, Actual);
end;
end Add_Collection_Actual_To_Build_In_Place_Call;
end Add_Finalization_Master_Actual_To_Build_In_Place_Call;
------------------------------
-- Add_Extra_Actual_To_Call --
@ -559,15 +559,15 @@ package body Exp_Ch6 is
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
begin
case Kind is
when BIP_Alloc_Form =>
when BIP_Alloc_Form =>
return "BIPalloc";
when BIP_Collection =>
return "BIPcollection";
when BIP_Master =>
when BIP_Finalization_Master =>
return "BIPfinalizationmaster";
when BIP_Master =>
return "BIPmaster";
when BIP_Activation_Chain =>
when BIP_Activation_Chain =>
return "BIPactivationchain";
when BIP_Object_Access =>
when BIP_Object_Access =>
return "BIPaccess";
end case;
end BIP_Formal_Suffix;
@ -2105,10 +2105,10 @@ package body Exp_Ch6 is
end if;
end if;
-- Detect the following code in Ada.Finalization.Heap_Management only
-- on .NET/JVM targets:
-- Detect the following code in System.Finalization_Masters only on
-- .NET/JVM targets:
--
-- procedure Finalize (Collection : in out Finalization_Collection) is
-- procedure Finalize (Master : in out Finalization_Master) is
-- begin
-- . . .
-- begin
@ -2124,7 +2124,7 @@ package body Exp_Ch6 is
and then Ekind (Scope (Curr_S)) = E_Procedure
and then Chars (Scope (Curr_S)) = Name_Finalize
and then Etype (First_Formal (Scope (Curr_S))) =
RTE (RE_Finalization_Collection)
RTE (RE_Finalization_Master)
then
declare
Deep_Fin : constant Entity_Id :=
@ -4393,20 +4393,20 @@ package body Exp_Ch6 is
Ret_Typ : Entity_Id;
Alloc_Expr : Node_Id) return Node_Id;
-- Create the statements necessary to allocate a return object on the
-- caller's collection. The collection is available through implicit
-- parameter BIPcollection.
-- caller's master. The master is available through implicit parameter
-- BIPfinalizationmaster.
--
-- if BIPcollection /= null then
-- if BIPfinalizationmaster /= null then
-- declare
-- type Ptr_Typ is access Ret_Typ;
-- for Ptr_Typ'Storage_Pool use
-- Base_Pool (BIPcollection.all).all;
-- Base_Pool (BIPfinalizationmaster.all).all;
-- Local : Ptr_Typ;
--
-- begin
-- procedure Allocate (...) is
-- begin
-- Ada.Finalization.Heap_Management.Allocate (...);
-- System.Storage_Pools.Subpools.Allocate_Any (...);
-- end Allocate;
--
-- Local := <Alloc_Expr>;
@ -4439,17 +4439,18 @@ package body Exp_Ch6 is
is
begin
-- Processing for build-in-place object allocation. This is disabled
-- on .NET/JVM because pools are not supported.
-- on .NET/JVM because the targets do not support pools.
if VM_Target = No_VM
and then Is_Build_In_Place_Function (Func_Id)
and then Needs_Finalization (Ret_Typ)
then
declare
Collect : constant Entity_Id :=
Build_In_Place_Formal (Func_Id, BIP_Collection);
Decls : constant List_Id := New_List;
Stmts : constant List_Id := New_List;
Decls : constant List_Id := New_List;
Fin_Mas_Id : constant Entity_Id :=
Build_In_Place_Formal
(Func_Id, BIP_Finalization_Master);
Stmts : constant List_Id := New_List;
Local_Id : Entity_Id;
Pool_Id : Entity_Id;
@ -4457,7 +4458,7 @@ package body Exp_Ch6 is
begin
-- Generate:
-- Pool_Id renames Base_Pool (BIPcollection.all).all;
-- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
Pool_Id := Make_Temporary (Loc, 'P');
@ -4474,11 +4475,12 @@ package body Exp_Ch6 is
New_Reference_To (RTE (RE_Base_Pool), Loc),
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Collect, Loc)))))));
Prefix =>
New_Reference_To (Fin_Mas_Id, Loc)))))));
-- Create an access type which uses the storage pool of the
-- caller's collection. This additional type is necessary
-- because the collection cannot be associated with the type
-- caller's master. This additional type is necessary because
-- the finalization master cannot be associated with the type
-- of the temporary. Otherwise the secondary stack allocation
-- will fail.
@ -4495,11 +4497,11 @@ package body Exp_Ch6 is
Subtype_Indication =>
New_Reference_To (Ret_Typ, Loc))));
-- Perform minor decoration in order to set the collection and
-- the storage pool attributes.
-- Perform minor decoration in order to set the master and the
-- storage pool attributes.
Set_Ekind (Ptr_Typ, E_Access_Type);
Set_Associated_Collection (Ptr_Typ, Collect);
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-- Create the temporary, generate:
@ -4534,12 +4536,12 @@ package body Exp_Ch6 is
New_Reference_To (Local_Id, Loc))));
-- Wrap the allocation in a block. This is further conditioned
-- by checking the caller collection at runtime. A null value
-- indicates a non-existent collection, most likely due to a
-- Finalize_Storage_Only allocation.
-- by checking the caller finalization master at runtime. A
-- null value indicates a non-existent master, most likely due
-- to a Finalize_Storage_Only allocation.
-- Generate:
-- if BIPcollection /= null then
-- if BIPfinalizationmaster /= null then
-- declare
-- <Decls>
-- begin
@ -4551,7 +4553,7 @@ package body Exp_Ch6 is
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Reference_To (Collect, Loc),
Left_Opnd => New_Reference_To (Fin_Mas_Id, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
@ -7110,7 +7112,7 @@ package body Exp_Ch6 is
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
Add_Collection_Actual_To_Build_In_Place_Call
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type);
Add_Task_Actuals_To_Build_In_Place_Call
@ -7144,7 +7146,7 @@ package body Exp_Ch6 is
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Global_Heap);
Add_Collection_Actual_To_Build_In_Place_Call
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type);
Add_Task_Actuals_To_Build_In_Place_Call
@ -7157,33 +7159,6 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, Return_Object => Empty);
end if;
-- If the build-in-place function call returns a controlled object, the
-- finalization collection will require a reference to routine Finalize_
-- Address of the designated type. Setting this attribute is done in the
-- same manner to expansion of allocators.
if Needs_Finalization (Result_Subt) then
-- Controlled types with supressed finalization do not need to
-- associate the address of their Finalize_Address primitives with a
-- collection since they do not need a collection to begin with.
if Is_Library_Level_Entity (Acc_Type)
and then Finalize_Storage_Only (Result_Subt)
then
null;
-- Do not generate the call to Make_Set_Finalize_Address_Ptr for
-- CodePeer compilations because Finalize_Address is never built.
elsif not CodePeer_Mode then
Insert_Action (Allocator,
Make_Set_Finalize_Address_Ptr_Call (Loc,
Typ => Etype (Function_Id),
Ptr_Typ => Acc_Type));
end if;
end if;
-- Finally, replace the allocator node with a reference to the result
-- of the function call itself (which will effectively be an access
-- to the object created by the allocator).
@ -7310,7 +7285,7 @@ package body Exp_Ch6 is
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
Add_Collection_Actual_To_Build_In_Place_Call
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
@ -7334,7 +7309,7 @@ package body Exp_Ch6 is
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
Add_Collection_Actual_To_Build_In_Place_Call
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
@ -7412,7 +7387,7 @@ package body Exp_Ch6 is
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
Add_Collection_Actual_To_Build_In_Place_Call
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Func_Id);
Add_Task_Actuals_To_Build_In_Place_Call
@ -7625,7 +7600,7 @@ package body Exp_Ch6 is
Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
end if;
Add_Collection_Actual_To_Build_In_Place_Call
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id);
if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
@ -7773,11 +7748,13 @@ package body Exp_Ch6 is
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
--------------------------
-- Needs_BIP_Collection --
--------------------------
-----------------------------------
-- Needs_BIP_Finalization_Master --
-----------------------------------
function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean is
function Needs_BIP_Finalization_Master
(Func_Id : Entity_Id) return Boolean
is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
@ -7785,6 +7762,6 @@ package body Exp_Ch6 is
return
not Restriction_Active (No_Finalization)
and then Needs_Finalization (Func_Typ);
end Needs_BIP_Collection;
end Needs_BIP_Finalization_Master;
end Exp_Ch6;

8
gcc/ada/exp_ch6.ads
View File

@ -68,9 +68,9 @@ package Exp_Ch6 is
-- caller or callee, and if the callee, whether to use the secondary
-- stack or the heap. See Create_Extra_Formals.
BIP_Collection,
BIP_Finalization_Master,
-- Present if result type needs finalization. Pointer to caller's
-- finalization collection.
-- finalization master.
BIP_Master,
-- Present if result type contains tasks. Master associated with
@ -163,8 +163,8 @@ package Exp_Ch6 is
-- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression
-- node applied to such a function call.
function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean;
function Needs_BIP_Finalization_Master (Func_Id : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Return True if the function needs a finalization
-- collection implicit parameter.
-- master implicit parameter.
end Exp_Ch6;

362
gcc/ada/exp_ch7.adb
View File

@ -431,8 +431,8 @@ package body Exp_Ch7 is
-- whether the inner logic should be dictated by state counters.
function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
-- Subsidiary to Make_Finalize_Address_Body and Make_Deep_Array_Body.
-- Generate the following statements:
-- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
-- Make_Deep_Record_Body. Generate the following statements:
--
-- declare
-- type Acc_Typ is access all Typ;
@ -797,11 +797,11 @@ package body Exp_Ch7 is
Parameter_Associations => Actuals)))));
end Build_Exception_Handler;
-----------------------------------
-- Build_Finalization_Collection --
-----------------------------------
-------------------------------
-- Build_Finalization_Master --
-------------------------------
procedure Build_Finalization_Collection
procedure Build_Finalization_Master
(Typ : Entity_Id;
Ins_Node : Node_Id := Empty;
Encl_Scope : Entity_Id := Empty)
@ -837,7 +837,7 @@ package body Exp_Ch7 is
return False;
end In_Deallocation_Instance;
-- Start of processing for Build_Finalization_Collection
-- Start of processing for Build_Finalization_Master
begin
-- Certain run-time configurations and targets do not provide support
@ -847,16 +847,13 @@ package body Exp_Ch7 is
return;
-- Various machinery such as freezing may have already created a
-- collection.
-- finalization master.
elsif Present (Associated_Collection (Typ)) then
elsif Present (Finalization_Master (Typ)) then
return;
-- Do not process types that return on the secondary stack
-- ??? The need for a secondary stack should be revisited and perhaps
-- changed.
elsif Present (Associated_Storage_Pool (Typ))
and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
then
@ -875,7 +872,7 @@ package body Exp_Ch7 is
return;
-- Ignore the general use of anonymous access types unless the context
-- requires a collection.
-- requires a finalization master.
elsif Ekind (Typ) = E_Anonymous_Access_Type
and then No (Ins_Node)
@ -883,7 +880,7 @@ package body Exp_Ch7 is
return;
-- Do not process non-library access types when restriction No_Nested_
-- Finalization is in effect since collections are controlled objects.
-- Finalization is in effect since masters are controlled objects.
elsif Restriction_Active (No_Nested_Finalization)
and then not Is_Library_Level_Entity (Typ)
@ -901,87 +898,85 @@ package body Exp_Ch7 is
end if;
declare
Loc : constant Source_Ptr := Sloc (Typ);
Actions : constant List_Id := New_List;
Coll_Id : Entity_Id;
Pool_Id : Entity_Id;
Loc : constant Source_Ptr := Sloc (Typ);
Actions : constant List_Id := New_List;
Fin_Mas_Id : Entity_Id;
Pool_Id : Entity_Id;
Ptr_Typ : Entity_Id := Typ;
begin
-- Access subtypes must use the storage pool of their base type
if Ekind (Ptr_Typ) = E_Access_Subtype then
Ptr_Typ := Base_Type (Ptr_Typ);
end if;
-- Generate:
-- Fnn : Finalization_Collection;
-- Fnn : aliased Finalization_Master;
-- Source access types use fixed names for their collections since
-- the collection is inserted only once in the same source unit and
-- there is no possible name overlap. Internally-generated access
-- types on the other hand use temporaries as collection names due
-- to possible name collisions.
-- Source access types use fixed master names since the master is
-- inserted in the same source unit only once. The only exception to
-- this are instances using the same access type as generic actual.
if Comes_From_Source (Typ) then
Coll_Id :=
if Comes_From_Source (Ptr_Typ)
and then not Inside_A_Generic
then
Fin_Mas_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "FC"));
Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
-- Internally generated access types use temporaries as their names
-- due to possible collision with identical names coming from other
-- packages.
else
Coll_Id := Make_Temporary (Loc, 'F');
Fin_Mas_Id := Make_Temporary (Loc, 'F');
end if;
Append_To (Actions,
Make_Object_Declaration (Loc,
Defining_Identifier => Coll_Id,
Defining_Identifier => Fin_Mas_Id,
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Finalization_Collection), Loc)));
New_Reference_To (RTE (RE_Finalization_Master), Loc)));
-- Storage pool selection and attribute decoration of the generated
-- collection. Since .NET/JVM compilers do not support pools, this
-- step is skipped.
-- master. Since .NET/JVM compilers do not support pools, this step
-- is skipped.
if VM_Target = No_VM then
-- If the access type has a user-defined pool, use it as the base
-- storage medium for the finalization pool.
if Present (Associated_Storage_Pool (Typ)) then
Pool_Id := Associated_Storage_Pool (Typ);
-- Access subtypes must use the storage pool of their base type
elsif Ekind (Typ) = E_Access_Subtype then
declare
Base_Typ : constant Entity_Id := Base_Type (Typ);
begin
if No (Associated_Storage_Pool (Base_Typ)) then
Pool_Id := Get_Global_Pool_For_Access_Type (Base_Typ);
Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
else
Pool_Id := Associated_Storage_Pool (Base_Typ);
end if;
end;
if Present (Associated_Storage_Pool (Ptr_Typ)) then
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
-- The default choice is the global pool
else
Pool_Id := Get_Global_Pool_For_Access_Type (Typ);
Set_Associated_Storage_Pool (Typ, Pool_Id);
Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
end if;
-- Generate:
-- Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
-- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
Append_To (Actions,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
Parameter_Associations => New_List (
New_Reference_To (Coll_Id, Loc),
New_Reference_To (Fin_Mas_Id, Loc),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Pool_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
Set_Associated_Collection (Typ, Coll_Id);
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
-- A finalization collection created for an anonymous access type
-- must be inserted before a context-dependent node.
-- A finalization master created for an anonymous access type must be
-- inserted before a context-dependent node.
if Present (Ins_Node) then
Push_Scope (Encl_Scope);
@ -1024,12 +1019,12 @@ package body Exp_Ch7 is
Append_Freeze_Actions (Typ, Actions);
-- If there's a pool created locally for the access type, then we
-- need to ensure that the collection gets created after the pool
-- object, because otherwise we can have a forward reference, so
-- we force the collection actions to be inserted and analyzed after
-- the pool entity. Note that both the access type and its designated
-- type may have already been frozen and had their freezing actions
-- analyzed at this point. (This seems a little unclean.???)
-- need to ensure that the master gets created after the pool object,
-- because otherwise we can have a forward reference, so we force the
-- master actions to be inserted and analyzed after the pool entity.
-- Note that both the access type and its designated type may have
-- already been frozen and had their freezing actions analyzed at
-- this point. (This seems a little unclean.???)
elsif VM_Target = No_VM
and then Scope (Pool_Id) = Scope (Typ)
@ -1040,7 +1035,7 @@ package body Exp_Ch7 is
Insert_Actions (Parent (Typ), Actions);
end if;
end;
end Build_Finalization_Collection;
end Build_Finalization_Master;
---------------------
-- Build_Finalizer --
@ -1933,15 +1928,15 @@ package body Exp_Ch7 is
end if;
-- Inspect the freeze node of an access-to-controlled type and
-- look for a delayed finalization collection. This case arises
-- when the freeze actions are inserted at a later time than the
-- look for a delayed finalization master. This case arises when
-- the freeze actions are inserted at a later time than the
-- expansion of the context. Since Build_Finalizer is never called
-- on a single construct twice, the collection will be ultimately
-- on a single construct twice, the master will be ultimately
-- left out and never finalized. This is also needed for freeze
-- actions of designated types themselves, since in some cases the
-- finalization collection is associated with a designated type's
-- finalization master is associated with a designated type's
-- freeze node rather than that of the access type (see handling
-- for freeze actions in Build_Finalization_Collection).
-- for freeze actions in Build_Finalization_Master).
elsif Nkind (Decl) = N_Freeze_Entity
and then Present (Actions (Decl))
@ -1958,12 +1953,12 @@ package body Exp_Ch7 is
-- Freeze nodes are considered to be identical to packages
-- and blocks in terms of nesting. The difference is that
-- a finalization collection created inside the freeze node
-- is at the same nesting level as the node itself.
-- a finalization master created inside the freeze node is
-- at the same nesting level as the node itself.
Process_Declarations (Actions (Decl), Preprocess);
-- The freeze node contains a finalization collection
-- The freeze node contains a finalization master
if Preprocess
and then Top_Level
@ -2086,11 +2081,12 @@ package body Exp_Ch7 is
-- following cleanup code:
--
-- if BIPallocfrom > Secondary_Stack'Pos
-- and then BIPcollection /= null
-- and then BIPfinalizationmaster /= null
-- then
-- declare
-- type Ptr_Typ is access Obj_Typ;
-- for Ptr_Typ'Storage_Pool use Base_Pool (BIPcollection);
-- for Ptr_Typ'Storage_Pool
-- use Base_Pool (BIPfinalizationmaster);
--
-- begin
-- Free (Ptr_Typ (Temp));
@ -2118,12 +2114,13 @@ package body Exp_Ch7 is
function Build_BIP_Cleanup_Stmts
(Func_Id : Entity_Id) return Node_Id
is
Collect : constant Entity_Id :=
Build_In_Place_Formal (Func_Id, BIP_Collection);
Decls : constant List_Id := New_List;
Obj_Typ : constant Entity_Id := Etype (Func_Id);
Temp_Id : constant Entity_Id :=
Entity (Prefix (Name (Parent (Obj_Id))));
Decls : constant List_Id := New_List;
Fin_Mas_Id : constant Entity_Id :=
Build_In_Place_Formal
(Func_Id, BIP_Finalization_Master);
Obj_Typ : constant Entity_Id := Etype (Func_Id);
Temp_Id : constant Entity_Id :=
Entity (Prefix (Name (Parent (Obj_Id))));
Cond : Node_Id;
Free_Blk : Node_Id;
@ -2133,7 +2130,7 @@ package body Exp_Ch7 is
begin
-- Generate:
-- Pool_Id renames Base_Pool (BIPcollection.all).all;
-- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
Pool_Id := Make_Temporary (Loc, 'P');
@ -2150,10 +2147,10 @@ package body Exp_Ch7 is
New_Reference_To (RTE (RE_Base_Pool), Loc),
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Collect, Loc)))))));
Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));
-- Create an access type which uses the storage pool of the
-- caller's collection.
-- caller's finalization master.
-- Generate:
-- type Ptr_Typ is access Obj_Typ;
@ -2167,11 +2164,11 @@ package body Exp_Ch7 is
Make_Access_To_Object_Definition (Loc,
Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
-- Perform minor decoration in order to set the collection and the
-- Perform minor decoration in order to set the master and the
-- storage pool attributes.
Set_Ekind (Ptr_Typ, E_Access_Type);
Set_Associated_Collection (Ptr_Typ, Collect);
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-- Create an explicit free statement. Note that the free uses the
@ -2203,18 +2200,18 @@ package body Exp_Ch7 is
Statements => New_List (Free_Stmt)));
-- Generate:
-- if BIPcollection /= null then
-- if BIPfinalizationmaster /= null then
Cond :=
Make_Op_Ne (Loc,
Left_Opnd => New_Reference_To (Collect, Loc),
Left_Opnd => New_Reference_To (Fin_Mas_Id, Loc),
Right_Opnd => Make_Null (Loc));
-- For constrained or tagged results escalate the condition to
-- include the allocation format. Generate:
--
-- if BIPallocform > Secondary_Stack'Pos
-- and then BIPcollection /= null
-- and then BIPfinalizationmaster /= null
-- then
if not Is_Constrained (Obj_Typ)
@ -2590,11 +2587,13 @@ package body Exp_Ch7 is
-- If we are dealing with a return object of a build-in-place
-- function, generate the following cleanup statements:
--
-- if BIPallocfrom > Secondary_Stack'Pos then
-- if BIPallocfrom > Secondary_Stack'Pos
-- and then BIPfinalizationmaster /= null
-- then
-- declare
-- type Ptr_Typ is access Obj_Typ;
-- for Ptr_Typ'Storage_Pool use
-- Base_Pool (BIPcollection.all).all;
-- Base_Pool (BIPfinalizationmaster.all).all;
--
-- begin
-- Free (Ptr_Typ (Temp));
@ -2602,17 +2601,15 @@ package body Exp_Ch7 is
-- end if;
--
-- The generated code effectively detaches the temporary from the
-- caller finalization chain and deallocates the object. This is
-- caller finalization master and deallocates the object. This is
-- disabled on .NET/JVM because pools are not supported.
-- H505-021 This needs to be revisited on .NET/JVM
if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
declare
Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
begin
if Is_Build_In_Place_Function (Func_Id)
and then Needs_BIP_Collection (Func_Id)
and then Needs_BIP_Finalization_Master (Func_Id)
then
Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
end if;
@ -4632,7 +4629,7 @@ package body Exp_Ch7 is
Name =>
New_Reference_To (RTE (RE_Attach), Loc),
Parameter_Associations => New_List (
New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
end Make_Attach_Call;
@ -6849,17 +6846,16 @@ package body Exp_Ch7 is
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
end if;
-- For types that are both controlled and have controlled components,
-- generate a call to Deep_Finalize.
-- Derivations from [Limited_]Controlled
elsif Is_Controlled (Utyp)
and then Has_Controlled_Component (Utyp)
then
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
elsif Is_Controlled (Utyp) then
if Has_Controlled_Component (Utyp) then
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
else
Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
end if;
-- For types that are not controlled themselves, but contain controlled
-- components or can be extended by types with controlled components,
-- create a call to Deep_Finalize.
-- Class-wide types, interfaces and types with controlled components
elsif Is_Class_Wide_Type (Typ)
or else Is_Interface (Typ)
@ -6871,11 +6867,13 @@ package body Exp_Ch7 is
Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
end if;
-- For types that are derived from Controlled and do not have controlled
-- components, build a call to Finalize.
-- Tagged types
elsif Is_Tagged_Type (Utyp) then
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
else
Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
raise Program_Error;
end if;
if Present (Fin_Id) then
@ -6927,6 +6925,9 @@ package body Exp_Ch7 is
--------------------------------
procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Proc_Id : Entity_Id;
begin
-- Nothing to do if the type is not controlled or it already has a
-- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
@ -6934,6 +6935,7 @@ package body Exp_Ch7 is
-- do not need the Finalize_Address primitive.
if not Needs_Finalization (Typ)
or else Is_Abstract_Type (Typ)
or else Present (TSS (Typ, TSS_Finalize_Address))
or else
(Is_Class_Wide_Type (Typ)
@ -6943,48 +6945,42 @@ package body Exp_Ch7 is
return;
end if;
declare
Loc : constant Source_Ptr := Sloc (Typ);
Proc_Id : Entity_Id;
Proc_Id :=
Make_Defining_Identifier (Loc,
Make_TSS_Name (Typ, TSS_Finalize_Address));
begin
Proc_Id :=
Make_Defining_Identifier (Loc,
Make_TSS_Name (Typ, TSS_Finalize_Address));
-- Generate:
-- procedure <Typ>FD (V : System.Address) is
-- begin
-- declare
-- type Pnn is access all Typ;
-- for Pnn'Storage_Size use 0;
-- begin
-- [Deep_]Finalize (Pnn (V).all);
-- end;
-- end TypFD;
-- Generate:
-- procedure TypFD (V : System.Address) is
-- begin
-- declare
-- type Pnn is access all Typ;
-- for Pnn'Storage_Size use 0;
-- begin
-- [Deep_]Finalize (Pnn (V).all);
-- end;
-- end TypFD;
Discard_Node (
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Discard_Node (
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_V),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)))),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_V),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)))),
Declarations => No_List,
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
Make_Finalize_Address_Stmts (Typ))));
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
Make_Finalize_Address_Stmts (Typ))));
Set_TSS (Typ, Proc_Id);
end;
Set_TSS (Typ, Proc_Id);
end Make_Finalize_Address_Body;
---------------------------------
@ -7415,86 +7411,6 @@ package body Exp_Ch7 is
Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
end Make_Local_Deep_Finalize;
----------------------------------------
-- Make_Set_Finalize_Address_Ptr_Call --
----------------------------------------
function Make_Set_Finalize_Address_Ptr_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Ptr_Typ : Entity_Id) return Node_Id
is
Desig_Typ : constant Entity_Id :=
Available_View (Designated_Type (Ptr_Typ));
Utyp : Entity_Id;
begin
-- If the context is a class-wide allocator, we use the class-wide type
-- to obtain the proper Finalize_Address routine.
if Is_Class_Wide_Type (Desig_Typ) then
Utyp := Desig_Typ;
else
Utyp := Typ;
if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
Utyp := Full_View (Utyp);
end if;
if Is_Concurrent_Type (Utyp) then
Utyp := Corresponding_Record_Type (Utyp);
end if;
end if;
Utyp := Underlying_Type (Base_Type (Utyp));
-- Deal with non-tagged derivation of private views. If the parent is
-- now known to be protected, the finalization routine is the one
-- defined on the corresponding record of the ancestor (corresponding
-- records do not automatically inherit operations, but maybe they
-- should???)
if Is_Untagged_Derivation (Typ) then
if Is_Protected_Type (Typ) then
Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
else
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
if Is_Protected_Type (Utyp) then
Utyp := Corresponding_Record_Type (Utyp);
end if;
end if;
end if;
-- If the underlying_type is a subtype, we are dealing with the
-- completion of a private type. We need to access the base type and
-- generate a conversion to it.
if Utyp /= Base_Type (Utyp) then
pragma Assert (Is_Private_Type (Typ));
Utyp := Base_Type (Utyp);
end if;
-- Generate:
-- Set_Finalize_Address_Ptr
-- (<Ptr_Typ>FC, <Utyp>FD'Unrestricted_Access);
return
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Set_Finalize_Address_Ptr), Loc),
Parameter_Associations => New_List (
New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
Attribute_Name => Name_Unrestricted_Access)));
end Make_Set_Finalize_Address_Ptr_Call;
--------------------------
-- Make_Transient_Block --
--------------------------

24
gcc/ada/exp_ch7.ads
View File

@ -40,15 +40,15 @@ package Exp_Ch7 is
-- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
-- that take care of finalization management at run-time.
procedure Build_Finalization_Collection
procedure Build_Finalization_Master
(Typ : Entity_Id;
Ins_Node : Node_Id := Empty;
Encl_Scope : Entity_Id := Empty);
-- Build a finalization collection for an access type. The designated type
-- may not necessarely be controlled or need finalization actions. The
-- routine creates a wrapper around a user-defined storage pool or the
-- general storage pool for access types. Ins_Nod and Encl_Scope are used
-- in conjunction with anonymous access types. Ins_Node designates the
-- Build a finalization master for an access type. The designated type may
-- not necessarely be controlled or need finalization actions. The routine
-- creates a wrapper around a user-defined storage pool or the general
-- storage pool for access types. Ins_Nod and Encl_Scope are used in
-- conjunction with anonymous access types. Ins_Node designates the
-- insertion point before which the collection should be added. Encl_Scope
-- is the scope of the context, either the enclosing record or the scope
-- of the related function.
@ -173,18 +173,6 @@ package Exp_Ch7 is
-- Create a special version of Deep_Finalize with identifier Nam. The
-- routine has state information and can parform partial finalization.
function Make_Set_Finalize_Address_Ptr_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Ptr_Typ : Entity_Id) return Node_Id;
-- Generate the following call:
--
-- Set_Finalize_Address_Ptr (<Ptr_Typ>FC, <Typ>FD'Unrestricted_Access);
--
-- where Finalize_Address is the corresponding TSS primitive of type Typ
-- and Ptr_Typ is the access type of the related allocation. Loc is the
-- source location of the related allocator.
--------------------------------------------
-- Task and Protected Object finalization --
--------------------------------------------

345
gcc/ada/exp_util.adb
View File

@ -332,6 +332,9 @@ package body Exp_Util is
Desig_Typ : constant Entity_Id :=
Available_View (Designated_Type (Ptr_Typ));
function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
-- Locate TSS primitive Finalize_Address in type Typ
function Find_Object (E : Node_Id) return Node_Id;
-- Given an arbitrary expression of an allocator, try to find an object
-- reference in it, otherwise return the original expression.
@ -340,6 +343,57 @@ package body Exp_Util is
-- Determine whether subprogram Subp denotes a custom allocate or
-- deallocate.
---------------------------
-- Find_Finalize_Address --
---------------------------
function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
Utyp : Entity_Id := Typ;
begin
if Is_Private_Type (Utyp)
and then Present (Full_View (Utyp))
then
Utyp := Full_View (Utyp);
end if;
if Is_Concurrent_Type (Utyp) then
Utyp := Corresponding_Record_Type (Utyp);
end if;
Utyp := Underlying_Type (Base_Type (Utyp));
-- Deal with non-tagged derivation of private views. If the parent is
-- now known to be protected, the finalization routine is the one
-- defined on the corresponding record of the ancestor (corresponding
-- records do not automatically inherit operations, but maybe they
-- should???)
if Is_Untagged_Derivation (Typ) then
if Is_Protected_Type (Typ) then
Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
else
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
if Is_Protected_Type (Utyp) then
Utyp := Corresponding_Record_Type (Utyp);
end if;
end if;
end if;
-- If the underlying_type is a subtype, we are dealing with the
-- completion of a private type. We need to access the base type and
-- generate a conversion to it.
if Utyp /= Base_Type (Utyp) then
pragma Assert (Is_Private_Type (Typ));
Utyp := Base_Type (Utyp);
end if;
return TSS (Utyp, TSS_Finalize_Address);
end Find_Finalize_Address;
-----------------
-- Find_Object --
-----------------
@ -375,8 +429,7 @@ package body Exp_Util is
function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
begin
-- Look for a subprogram body with only one statement which is a
-- call to one of the Allocate / Deallocate routines in package
-- Ada.Finalization.Heap_Management.
-- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
if Ekind (Subp) = E_Procedure
and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
@ -394,8 +447,8 @@ package body Exp_Util is
Proc := Entity (Name (First (Statements (HSS))));
return
Is_RTE (Proc, RE_Allocate)
or else Is_RTE (Proc, RE_Deallocate);
Is_RTE (Proc, RE_Allocate_Any_Controlled)
or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
end if;
end;
end if;
@ -430,137 +483,191 @@ package body Exp_Util is
Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
Actuals : List_Id;
Collect_Act : Node_Id;
Collect_Id : Entity_Id;
Collect_Typ : Entity_Id;
Fin_Addr_Id : Entity_Id;
Fin_Mas_Act : Node_Id;
Fin_Mas_Id : Entity_Id;
Fin_Mas_Typ : Entity_Id;
Proc_To_Call : Entity_Id;
begin
-- When dealing with an access subtype, use the collection of the
-- base type.
-- When dealing with an access subtype, always use the base type
-- since it carries all the attributes.
if Ekind (Ptr_Typ) = E_Access_Subtype then
Collect_Typ := Base_Type (Ptr_Typ);
Fin_Mas_Typ := Base_Type (Ptr_Typ);
else
Collect_Typ := Ptr_Typ;
Fin_Mas_Typ := Ptr_Typ;
end if;
Collect_Id := Associated_Collection (Collect_Typ);
Collect_Act := New_Reference_To (Collect_Id, Loc);
Actuals := New_List;
-- Handle the case where the collection is actually a pointer to a
-- collection. This case arises in build-in-place functions.
-- Step 1: Construct all the actuals for the call to library routine
-- Allocate_Any_Controlled / Deallocate_Any_Controlled.
if Is_Access_Type (Etype (Collect_Id)) then
Collect_Act :=
Make_Explicit_Dereference (Loc,
Prefix => Collect_Act);
-- a) Storage pool
Append_To (Actuals,
New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc));
if Is_Allocate then
-- b) Subpool
if Present (Subpool_Handle_Name (Expr)) then
Append_To (Actuals,
New_Reference_To (Entity (Subpool_Handle_Name (Expr)), Loc));
else
Append_To (Actuals, Make_Null (Loc));
end if;
-- c) Finalization master
if Needs_Finalization (Desig_Typ) then
Fin_Mas_Id := Finalization_Master (Fin_Mas_Typ);
Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
-- Handle the case where the master is actually a pointer to a
-- master. This case arises in build-in-place functions.
if Is_Access_Type (Etype (Fin_Mas_Id)) then
Append_To (Actuals, Fin_Mas_Act);
else
Append_To (Actuals,
Make_Attribute_Reference (Loc,
Prefix => Fin_Mas_Act,
Attribute_Name => Name_Unrestricted_Access));
end if;
else
Append_To (Actuals, Make_Null (Loc));
end if;
-- d) Finalize_Address
Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
if Present (Fin_Addr_Id) then
Append_To (Actuals,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Fin_Addr_Id, Loc),
Attribute_Name => Name_Unrestricted_Access));
else
Append_To (Actuals, Make_Null (Loc));
end if;
end if;
-- Create the actuals for the call to Allocate / Deallocate
-- e) Address
-- f) Storage_Size
-- g) Alignment
Actuals := New_List (
Collect_Act,
New_Reference_To (Addr_Id, Loc),
New_Reference_To (Size_Id, Loc),
New_Reference_To (Alig_Id, Loc));
Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
Append_To (Actuals, New_Reference_To (Size_Id, Loc));
Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
-- h) Is_Controlled
-- Generate a run-time check to determine whether a class-wide object
-- is truly controlled.
if Is_Class_Wide_Type (Desig_Typ)
or else Is_Generic_Actual_Type (Desig_Typ)
then
declare
Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
Flag_Expr : Node_Id;
Param : Node_Id;
Temp : Node_Id;
begin
if Is_Allocate then
Temp := Find_Object (Expression (Expr));
else
Temp := Expr;
end if;
-- Processing for generic actuals
if Is_Generic_Actual_Type (Desig_Typ) then
Flag_Expr :=
New_Reference_To (Boolean_Literals
(Needs_Finalization (Base_Type (Desig_Typ))), Loc);
-- Processing for subtype indications
elsif Nkind (Temp) in N_Has_Entity
and then Is_Type (Entity (Temp))
then
Flag_Expr :=
New_Reference_To (Boolean_Literals
(Needs_Finalization (Entity (Temp))), Loc);
-- Generate a runtime check to test the controlled state of an
-- object for the purposes of allocation / deallocation.
else
-- The following case arises when allocating through an
-- interface class-wide type, generate:
--
-- Temp.all
if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
Param :=
Make_Explicit_Dereference (Loc,
Prefix =>
Relocate_Node (Temp));
-- Generate:
-- Temp'Tag
if Needs_Finalization (Desig_Typ) then
if Is_Class_Wide_Type (Desig_Typ)
or else Is_Generic_Actual_Type (Desig_Typ)
then
declare
Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
Flag_Expr : Node_Id;
Param : Node_Id;
Temp : Node_Id;
begin
if Is_Allocate then
Temp := Find_Object (Expression (Expr));
else
Param :=
Make_Attribute_Reference (Loc,
Prefix =>
Relocate_Node (Temp),
Attribute_Name => Name_Tag);
Temp := Expr;
end if;
-- Generate:
-- Needs_Finalization (Param)
-- Processing for generic actuals
Flag_Expr :=
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Needs_Finalization), Loc),
Parameter_Associations => New_List (Param));
end if;
if Is_Generic_Actual_Type (Desig_Typ) then
Flag_Expr :=
New_Reference_To (Boolean_Literals
(Needs_Finalization (Base_Type (Desig_Typ))), Loc);
-- Create the temporary which represents the finalization state
-- of the expression. Generate:
--
-- F : constant Boolean := <Flag_Expr>;
-- Processing for subtype indications
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Flag_Id,
Constant_Present => True,
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc),
Expression => Flag_Expr));
elsif Nkind (Temp) in N_Has_Entity
and then Is_Type (Entity (Temp))
then
Flag_Expr :=
New_Reference_To (Boolean_Literals
(Needs_Finalization (Entity (Temp))), Loc);
-- The flag acts as the fifth actual
-- Generate a runtime check to test the controlled state of
-- an object for the purposes of allocation / deallocation.
Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
end;
else
-- The following case arises when allocating through an
-- interface class-wide type, generate:
--
-- Temp.all
if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
Param :=
Make_Explicit_Dereference (Loc,
Prefix =>
Relocate_Node (Temp));
-- Generate:
-- Temp'Tag
else
Param :=
Make_Attribute_Reference (Loc,
Prefix =>
Relocate_Node (Temp),
Attribute_Name => Name_Tag);
end if;
-- Generate:
-- Needs_Finalization (<Param>)
Flag_Expr :=
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Needs_Finalization), Loc),
Parameter_Associations => New_List (Param));
end if;
-- Create the temporary which represents the finalization
-- state of the expression. Generate:
--
-- F : constant Boolean := <Flag_Expr>;
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Flag_Id,
Constant_Present => True,
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc),
Expression => Flag_Expr));
-- The flag acts as the last actual
Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
end;
end if;
else
Append_To (Actuals, New_Reference_To (Standard_False, Loc));
end if;
-- Step 2: Build a wrapper Allocate / Deallocate which internally
-- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
-- Select the proper routine to call
if Is_Allocate then
Proc_To_Call := RTE (RE_Allocate);
Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
else
Proc_To_Call := RTE (RE_Deallocate);
Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
end if;
-- Create a custom Allocate / Deallocate routine which has identical
@ -611,10 +718,6 @@ package body Exp_Util is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
-- Allocate / Deallocate
-- (<Ptr_Typ collection>, A, S, L[, F]);
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Proc_To_Call, Loc),
@ -3752,7 +3855,7 @@ package body Exp_Util is
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
-- Do not consider transient objects allocated on the heap since they
-- are attached to a finalization collection.
-- are attached to a finalization master.
and then not Is_Allocated (Obj_Id)
@ -6431,16 +6534,16 @@ package body Exp_Util is
return True;
end if;
-- Inspect the freeze node of an access-to-controlled type and
-- look for a delayed finalization collection. This case arises
-- when the freeze actions are inserted at a later time than the
-- expansion of the context. Since Build_Finalizer is never called
-- on a single construct twice, the collection will be ultimately
-- left out and never finalized. This is also needed for freeze
-- actions of designated types themselves, since in some cases the
-- finalization collection is associated with a designated type's
-- freeze node rather than that of the access type (see handling
-- for freeze actions in Build_Finalization_Collection).
-- Inspect the freeze node of an access-to-controlled type and look
-- for a delayed finalization master. This case arises when the
-- freeze actions are inserted at a later time than the expansion of
-- the context. Since Build_Finalizer is never called on a single
-- construct twice, the master will be ultimately left out and never
-- finalized. This is also needed for freeze actions of designated
-- types themselves, since in some cases the finalization master is
-- associated with a designated type's freeze node rather than that
-- of the access type (see handling for freeze actions in
-- Build_Finalization_Master).
elsif Nkind (Decl) = N_Freeze_Entity
and then Present (Actions (Decl))
@ -6451,9 +6554,9 @@ package body Exp_Util is
and then not Is_Access_Subprogram_Type (Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Typ))))
or else
(Is_Type (Typ)
and then Needs_Finalization (Typ)))
or else
(Is_Type (Typ)
and then Needs_Finalization (Typ)))
and then Requires_Cleanup_Actions
(Actions (Decl), For_Package, Nested_Constructs)
then

16
gcc/ada/exp_util.ads
View File

@ -202,21 +202,7 @@ package Exp_Util is
-- allocation, N is the declaration of the temporary variable which
-- represents the expression of the original allocator node, otherwise N
-- must be a free statement. If flag Is_Allocate is set, the generated
-- routine is allocate, deallocate otherwise. The generated routine is:
--
-- F : constant Boolean := -- CW case
-- Ada.Tags.Needs_Finalization (<Expr>'Tag); -- CW case
--
-- procedure Allocate / Deallocate
-- (P : Storage_Pool;
-- A : [out] Address; -- out is present for Allocate
-- S : Storage_Count;
-- L : Storage_Count)
-- is
-- begin
-- Allocate / Deallocate
-- (<Ptr_Typ collection>, A, S, L, [Needs_Header => F]);
-- end Allocate;
-- routine is allocate, deallocate otherwise.
function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id;
-- Build an N_Procedure_Call_Statement calling the given runtime entity.

28
gcc/ada/freeze.adb
View File

@ -1432,27 +1432,27 @@ package body Freeze is
end loop;
end;
-- We add finalization collections to access types whose designated
-- types require finalization. This is normally done when freezing
-- the type, but this misses recursive type definitions where the
-- later members of the recursion introduce controlled components
-- (such as can happen when incomplete types are involved), as well
-- cases where a component type is private and the controlled full
-- type occurs after the access type is frozen. Cases that don't
-- need a finalization collection are generic formal types (the
-- actual type will have it) and types with Java and CIL conventions,
-- since those are used for API bindings. (Are there any other cases
-- that should be excluded here???)
-- We add finalization masters to access types whose designated types
-- require finalization. This is normally done when freezing the
-- type, but this misses recursive type definitions where the later
-- members of the recursion introduce controlled components (such as
-- can happen when incomplete types are involved), as well cases
-- where a component type is private and the controlled full type
-- occurs after the access type is frozen. Cases that don't need a
-- finalization master are generic formal types (the actual type will
-- have it) and types with Java and CIL conventions, since those are
-- used for API bindings. (Are there any other cases that should be
-- excluded here???)
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
and then not Is_Generic_Type (E)
and then Needs_Finalization (Designated_Type (E))
and then No (Associated_Collection (E))
and then No (Finalization_Master (E))
and then Convention (Designated_Type (E)) /= Convention_Java
and then Convention (Designated_Type (E)) /= Convention_CIL
then
Build_Finalization_Collection (E);
Build_Finalization_Master (E);
end if;
Next_Entity (E);
@ -2029,7 +2029,7 @@ package body Freeze is
Next_Entity (Comp);
end loop;
-- Deal with Bit_Order aspect specifying a non-default bit order
-- Deal with pragma Bit_Order setting non-standard bit order
if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
if not Placed_Component then

2
gcc/ada/impunit.adb
View File

@ -111,6 +111,7 @@ package body Impunit is
"a-titest", -- Ada.Text_IO.Text_Streams
"a-unccon", -- Ada.Unchecked_Conversion
"a-uncdea", -- Ada.Unchecked_Deallocation
"a-undesu", -- Ada.Unchecked_Deallocate_Subpool
"a-witeio", -- Ada.Wide_Text_IO
"a-wtcoio", -- Ada.Wide_Text_IO.Complex_IO
"a-wtedit", -- Ada.Wide_Text_IO.Editing
@ -339,6 +340,7 @@ package body Impunit is
"s-rpc ", -- System.Rpc
"s-stoele", -- System.Storage_Elements
"s-stopoo", -- System.Storage_Pools
"s-stposu", -- System.Storage_Pools.Subpools
--------------------------------------
-- GNAT Defined Additions to System --

9
gcc/ada/rtsfind.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, 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- --
@ -293,9 +293,6 @@ package body Rtsfind is
elsif U_Id in Ada_Dispatching_Child then
Name_Buffer (16) := '.';
elsif U_Id in Ada_Finalization_Child then
Name_Buffer (17) := '.';
elsif U_Id in Ada_Interrupts_Child then
Name_Buffer (15) := '.';
@ -324,6 +321,10 @@ package body Rtsfind is
elsif U_Id in System_Child then
Name_Buffer (7) := '.';
if U_Id in System_Storage_Pools_Child then
Name_Buffer (21) := '.';
end if;
if U_Id in System_Strings_Child then
Name_Buffer (15) := '.';
end if;

78
gcc/ada/rtsfind.ads
View File

@ -48,9 +48,6 @@ package Rtsfind is
-- eventually, packages implementing delays will be found relative to
-- the package that declares the time type.
-- Names of the form Ada_Finalization_xxx are second level children of
-- Ada.Finalization.
-- Names of the form Ada_Interrupts_xxx are second level children of
-- Ada.Interrupts. This is needed for Ada.Interrupts.Names which is used
-- by pragma Interrupt_State.
@ -80,6 +77,9 @@ package Rtsfind is
-- name is System.xxx. For example, the name System_Str_Concat refers to
-- package System.Str_Concat.
-- Names of the form System_Storage_Pools_xxx are second level children
-- of the package System.Storage_Pools.
-- Names of the form System_Strings_xxx are second level children of the
-- package System.Strings.
@ -140,10 +140,6 @@ package Rtsfind is
Ada_Dispatching_EDF,
-- Children of Ada.Finalization
Ada_Finalization_Heap_Management,
-- Children of Ada.Interrupts
Ada_Interrupts_Names,
@ -249,6 +245,7 @@ package Rtsfind is
System_Fat_VAX_D_Float,
System_Fat_VAX_F_Float,
System_Fat_VAX_G_Float,
System_Finalization_Masters,
System_Finalization_Root,
System_Fore,
System_Img_Bool,
@ -374,6 +371,10 @@ package Rtsfind is
System_WWd_Enum,
System_WWd_Wchar,
-- Children of System.Storage_Pools
System_Storage_Pools_Subpools,
-- Children of System.Strings
System_Strings_Stream_Ops,
@ -403,10 +404,6 @@ package Rtsfind is
range Ada_Dispatching_EDF .. Ada_Dispatching_EDF;
-- Range of values for children of Ada.Dispatching
subtype Ada_Finalization_Child is Ada_Child range
Ada_Finalization_Heap_Management .. Ada_Finalization_Heap_Management;
-- Range of values for children of Ada.Finalization
subtype Ada_Interrupts_Child is Ada_Child range
Ada_Interrupts_Names .. Ada_Interrupts_Names;
-- Range of values for children of Ada.Interrupts
@ -443,6 +440,9 @@ package Rtsfind is
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
subtype System_Storage_Pools_Child is RTU_Id
range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools;
subtype System_Strings_Child is RTU_Id
range System_Strings_Stream_Ops .. System_Strings_Stream_Ops;
@ -521,17 +521,6 @@ package Rtsfind is
RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions
RE_Save_Occurrence, -- Ada.Exceptions
RE_Add_Offset_To_Address, -- Ada.Finalization.Heap_Management
RE_Allocate, -- Ada.Finalization.Heap_Management
RE_Attach, -- Ada.Finalization.Heap_Management
RE_Base_Pool, -- Ada.Finalization.Heap_Management
RE_Deallocate, -- Ada.Finalization.Heap_Management
RE_Detach, -- Ada.Finalization.Heap_Management
RE_Finalization_Collection, -- Ada.Finalization.Heap_Management
RE_Finalization_Collection_Ptr, -- Ada.Finalization.Heap_Management
RE_Set_Finalize_Address_Ptr, -- Ada.Finalization.Heap_Management
RE_Set_Storage_Pool_Ptr, -- Ada.Finalization.Heap_Management
RE_Interrupt_ID, -- Ada.Interrupts
RE_Is_Reserved, -- Ada.Interrupts
RE_Is_Attached, -- Ada.Interrupts
@ -805,6 +794,14 @@ package Rtsfind is
RE_Attr_VAX_G_Float, -- System.Fat_VAX_G_Float
RE_Fat_VAX_G, -- System.Fat_VAX_G_Float
RE_Add_Offset_To_Address, -- System.Finalization_Masters
RE_Attach, -- System.Finalization_Masters
RE_Base_Pool, -- System.Finalization_Masters
RE_Detach, -- System.Finalization_Masters
RE_Finalization_Master, -- System.Finalization_Masters
RE_Finalization_Master_Ptr, -- System.Finalization_Masters
RE_Set_Base_Pool, -- System.Finalization_Masters
RE_Root_Controlled, -- System.Finalization_Root
RE_Root_Controlled_Ptr, -- System.Finalization_Root
@ -1327,9 +1324,15 @@ package Rtsfind is
RE_Storage_Offset, -- System.Storage_Elements
RE_To_Address, -- System.Storage_Elements
RE_Allocate_Any, -- System.Storage_Pools
RE_Deallocate_Any, -- System.Storage_Pools
RE_Root_Storage_Pool, -- System.Storage_Pools
RE_Allocate_Any, -- System.Storage_Pools,
RE_Deallocate_Any, -- System.Storage_Pools,
RE_Allocate_Any_Controlled, -- System.Storage_Pools.Subpools
RE_Deallocate_Any_Controlled, -- 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
RE_I_AD, -- System.Stream_Attributes
RE_I_AS, -- System.Stream_Attributes
@ -1704,17 +1707,6 @@ package Rtsfind is
RE_Reraise_Occurrence_No_Defer => Ada_Exceptions,
RE_Save_Occurrence => Ada_Exceptions,
RE_Add_Offset_To_Address => Ada_Finalization_Heap_Management,
RE_Allocate => Ada_Finalization_Heap_Management,
RE_Attach => Ada_Finalization_Heap_Management,
RE_Base_Pool => Ada_Finalization_Heap_Management,
RE_Deallocate => Ada_Finalization_Heap_Management,
RE_Detach => Ada_Finalization_Heap_Management,
RE_Finalization_Collection => Ada_Finalization_Heap_Management,
RE_Finalization_Collection_Ptr => Ada_Finalization_Heap_Management,
RE_Set_Finalize_Address_Ptr => Ada_Finalization_Heap_Management,
RE_Set_Storage_Pool_Ptr => Ada_Finalization_Heap_Management,
RE_Interrupt_ID => Ada_Interrupts,
RE_Is_Reserved => Ada_Interrupts,
RE_Is_Attached => Ada_Interrupts,
@ -1988,6 +1980,14 @@ package Rtsfind is
RE_Attr_VAX_G_Float => System_Fat_VAX_G_Float,
RE_Fat_VAX_G => System_Fat_VAX_G_Float,
RE_Add_Offset_To_Address => System_Finalization_Masters,
RE_Attach => System_Finalization_Masters,
RE_Base_Pool => System_Finalization_Masters,
RE_Detach => System_Finalization_Masters,
RE_Finalization_Master => System_Finalization_Masters,
RE_Finalization_Master_Ptr => System_Finalization_Masters,
RE_Set_Base_Pool => System_Finalization_Masters,
RE_Root_Controlled => System_Finalization_Root,
RE_Root_Controlled_Ptr => System_Finalization_Root,
@ -2510,9 +2510,15 @@ package Rtsfind is
RE_Storage_Offset => System_Storage_Elements,
RE_To_Address => System_Storage_Elements,
RE_Root_Storage_Pool => System_Storage_Pools,
RE_Allocate_Any => System_Storage_Pools,
RE_Deallocate_Any => System_Storage_Pools,
RE_Root_Storage_Pool => System_Storage_Pools,
RE_Allocate_Any_Controlled => System_Storage_Pools_Subpools,
RE_Deallocate_Any_Controlled => 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,
RE_I_AD => System_Stream_Attributes,
RE_I_AS => System_Stream_Attributes,

214
gcc/ada/s-finmas.adb Normal file
View File

@ -0,0 +1,214 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions; use Ada.Exceptions;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
package body System.Finalization_Masters is
---------------------------
-- Add_Offset_To_Address --
---------------------------
function Add_Offset_To_Address
(Addr : System.Address;
Offset : System.Storage_Elements.Storage_Offset) return System.Address
is
begin
return System.Storage_Elements."+" (Addr, Offset);
end Add_Offset_To_Address;
------------
-- Attach --
------------
procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
begin
Lock_Task.all;
L.Next.Prev := N;
N.Next := L.Next;
L.Next := N;
N.Prev := L;
Unlock_Task.all;
-- Note: No need to unlock in case of an exception because the above
-- code can never raise one.
end Attach;
---------------
-- Base_Pool --
---------------
function Base_Pool
(Master : Finalization_Master) return Any_Storage_Pool_Ptr
is
begin
return Master.Base_Pool;
end Base_Pool;
------------
-- Detach --
------------
procedure Detach (N : not null FM_Node_Ptr) is
begin
-- N must be attached to some list
pragma Assert (N.Next /= null and then N.Prev /= null);
Lock_Task.all;
N.Prev.Next := N.Next;
N.Next.Prev := N.Prev;
Unlock_Task.all;
-- Note: No need to unlock in case of an exception because the above
-- code can never raise one.
end Detach;
--------------
-- Finalize --
--------------
overriding procedure Finalize (Master : in out Finalization_Master) is
Curr_Ptr : FM_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Obj_Addr : Address;
Raised : Boolean := False;
begin
-- It is possible for multiple tasks to cause the finalization of the
-- same master. Let only one task finalize the objects.
if Master.Finalization_Started then
return;
end if;
-- Lock the master to prevent any allocations while the objects are
-- being finalized. The master remains locked because either the master
-- is explicitly deallocated or the associated access type is about to
-- go out of scope.
Master.Finalization_Started := True;
-- Skip the dummy head
Curr_Ptr := Master.Objects.Next;
while Curr_Ptr /= Master.Objects'Unchecked_Access loop
begin
-- If primitive Finalize_Address is not set, then the expansion of
-- the designated type or that of the allocator failed. This is a
-- serious error.
-- Note: The Program_Error must be raised from the same block as
-- the finalization call. If Finalize_Address is not present for
-- a particular object, this should not stop the finalization of
-- the remaining objects.
if Curr_Ptr.Finalize_Address = null then
raise Program_Error
with "primitive Finalize_Address not available";
-- Skip the list header in order to offer proper object layout for
-- finalization and call Finalize_Address.
else
Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
Curr_Ptr.Finalize_Address (Obj_Addr);
end if;
exception
when Fin_Occur : others =>
if not Raised then
Raised := True;
Save_Occurrence (Ex_Occur, Fin_Occur);
end if;
end;
Curr_Ptr := Curr_Ptr.Next;
end loop;
-- If the finalization of a particular object failed or Finalize_Address
-- was not set, reraise the exception now.
if Raised then
Reraise_Occurrence (Ex_Occur);
end if;
end Finalize;
-----------------
-- Header_Size --
-----------------
function Header_Size return System.Storage_Elements.Storage_Count is
begin
return FM_Node'Size / Storage_Unit;
end Header_Size;
-------------------
-- Header_Offset --
-------------------
function Header_Offset return System.Storage_Elements.Storage_Offset is
begin
return FM_Node'Size / Storage_Unit;
end Header_Offset;
----------------
-- Initialize --
----------------
overriding procedure Initialize (Master : in out Finalization_Master) is
begin
-- The dummy head must point to itself in both directions
Master.Objects.Next := Master.Objects'Unchecked_Access;
Master.Objects.Prev := Master.Objects'Unchecked_Access;
end Initialize;
-------------------
-- Set_Base_Pool --
-------------------
procedure Set_Base_Pool
(Master : in out Finalization_Master;
Pool_Ptr : Any_Storage_Pool_Ptr)
is
begin
Master.Base_Pool := Pool_Ptr;
end Set_Base_Pool;
end System.Finalization_Masters;

135
gcc/ada/s-finmas.ads Normal file
View File

@ -0,0 +1,135 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Finalization;
with Ada.Unchecked_Conversion;
with System.Storage_Elements;
with System.Storage_Pools;
package System.Finalization_Masters is
pragma Preelaborate (System.Finalization_Masters);
-- A reference to primitive Finalize_Address. The expander generates an
-- implementation of this procedure for each controlled and class-wide
-- type. Since controlled objects are simply viewed as addresses once
-- allocated through a master, Finalize_Address provides a backward
-- indirection from an address to a type-specific context.
type Finalize_Address_Ptr is access procedure (Obj : System.Address);
-- Heterogeneous collection type structure. The implementation allows for
-- finalizable objects of different base types to be serviced by the same
-- master.
type FM_Node;
type FM_Node_Ptr is access all FM_Node;
type FM_Node is record
Prev : FM_Node_Ptr := null;
Next : FM_Node_Ptr := null;
Finalize_Address : Finalize_Address_Ptr := null;
end record;
-- A reference to any derivation from Root_Storage_Pool. Since this type
-- may not be used to allocate objects, its storage size is zero.
type Any_Storage_Pool_Ptr is
access System.Storage_Pools.Root_Storage_Pool'Class;
for Any_Storage_Pool_Ptr'Storage_Size use 0;
-- Finalization master type structure. A unique master is associated with
-- each access-to-controlled or access-to-class-wide type. Masters also act
-- as components of subpools.
type Finalization_Master is
new Ada.Finalization.Limited_Controlled with
record
Base_Pool : Any_Storage_Pool_Ptr := null;
-- A reference to the pool which this finalization master services. This
-- field is used in conjunction with the build-in-place machinery.
Objects : aliased FM_Node;
-- A doubly linked list which contains the headers of all controlled
-- objects allocated in a [sub]pool.
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- A flag used to detect allocations which occur during the finalization
-- of a master. The allocations must raise Program_Error. This scenario
-- may arise in a multitask environment. The flag is atomic because it
-- is accessed without Lock_Task / Unlock_Task.
end record;
type Finalization_Master_Ptr is access all Finalization_Master;
for Finalization_Master_Ptr'Storage_Size use 0;
-- Since RTSfind cannot contain names of the form RE_"+", the following
-- routine serves as a wrapper around System.Storage_Elements."+".
function Add_Offset_To_Address
(Addr : System.Address;
Offset : System.Storage_Elements.Storage_Offset) return System.Address;
function Address_To_FM_Node_Ptr is
new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
-- Prepend a node to a specific finalization master
function Base_Pool
(Master : Finalization_Master) return Any_Storage_Pool_Ptr;
-- Return a reference to the underlying storage pool on which the master
-- operates.
procedure Detach (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master
overriding procedure Finalize (Master : in out Finalization_Master);
-- Lock the master to prevent allocations during finalization. Iterate over
-- the list of allocated controlled objects, finalizing each one by calling
-- its specific Finalize_Address. In the end, deallocate the dummy head.
function Header_Size return System.Storage_Elements.Storage_Count;
-- Return the size of type FM_Node as Storage_Count
function Header_Offset return System.Storage_Elements.Storage_Offset;
-- Return the size of type FM_Node as Storage_Offset
overriding procedure Initialize (Master : in out Finalization_Master);
-- Initialize the dummy head of a finalization master
procedure Set_Base_Pool
(Master : in out Finalization_Master;
Pool_Ptr : Any_Storage_Pool_Ptr);
-- Set the underlying pool of a finalization master
end System.Finalization_Masters;

13
gcc/ada/s-stopoo.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009 Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, 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- --
@ -37,13 +37,12 @@ package body System.Storage_Pools is
procedure Allocate_Any
(Pool : in out Root_Storage_Pool'Class;
Storage_Address : out Address;
Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is
begin
Allocate
(Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
Allocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
end Allocate_Any;
--------------------
@ -52,12 +51,12 @@ package body System.Storage_Pools is
procedure Deallocate_Any
(Pool : in out Root_Storage_Pool'Class;
Storage_Address : Address;
Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is
begin
Deallocate
(Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
Deallocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
end Deallocate_Any;
end System.Storage_Pools;

19
gcc/ada/s-stopoo.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -44,14 +44,14 @@ package System.Storage_Pools is
procedure Allocate
(Pool : in out Root_Storage_Pool;
Storage_Address : out Address;
Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is abstract;
procedure Deallocate
(Pool : in out Root_Storage_Pool;
Storage_Address : Address;
Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is abstract;
@ -62,6 +62,13 @@ package System.Storage_Pools is
is abstract;
private
type Root_Storage_Pool is abstract
new Ada.Finalization.Limited_Controlled with null record;
-- ??? Are these two still needed? It might be possible to use Subpools.
-- Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled
-- objects.
-- The following two procedures support the use of class-wide pool
-- objects in storage pools. When a local type is given a class-wide
-- storage pool, allocation and deallocation for the type must dispatch
@ -71,16 +78,14 @@ private
procedure Allocate_Any
(Pool : in out Root_Storage_Pool'Class;
Storage_Address : out Address;
Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count);
procedure Deallocate_Any
(Pool : in out Root_Storage_Pool'Class;
Storage_Address : Address;
Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count);
type Root_Storage_Pool is abstract
new Ada.Finalization.Limited_Controlled with null record;
end System.Storage_Pools;

473
gcc/ada/s-stposu.adb Normal file
View File

@ -0,0 +1,473 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Deallocation;
with System.Finalization_Masters; use System.Finalization_Masters;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
package body System.Storage_Pools.Subpools is
procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
-- Attach a subpool node to a pool
procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr);
procedure Detach (N : not null SP_Node_Ptr);
-- Unhook a subpool node from an arbitrary subpool list
--------------
-- Allocate --
--------------
overriding procedure Allocate
(Pool : in out Root_Storage_Pool_With_Subpools;
Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is
begin
-- ??? The use of Allocate is very dangerous as it does not handle
-- controlled objects properly. Perhaps we should provide an
-- implementation which raises Program_Error instead.
-- Dispatch to the user-defined implementations of Allocate_From_Subpool
-- and Default_Subpool_For_Pool.
Allocate_From_Subpool
(Root_Storage_Pool_With_Subpools'Class (Pool),
Storage_Address,
Size_In_Storage_Elements,
Alignment,
Default_Subpool_For_Pool
(Root_Storage_Pool_With_Subpools'Class (Pool)));
end Allocate;
-----------------------------
-- Allocate_Any_Controlled --
-----------------------------
procedure Allocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
Context_Subpool : Subpool_Handle := null;
Context_Master : Finalization_Masters.Finalization_Master_Ptr := null;
Fin_Address : Finalization_Masters.Finalize_Address_Ptr := null;
Addr : out System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True)
is
-- ??? This membership test gives the wrong result when Pool has
-- subpools.
Is_Subpool_Allocation : constant Boolean :=
Pool in Root_Storage_Pool_With_Subpools;
Master : Finalization_Master_Ptr := null;
N_Addr : Address;
N_Ptr : FM_Node_Ptr;
N_Size : Storage_Count;
Subpool : Subpool_Handle := null;
begin
-- Step 1: Pool-related runtime checks
-- Allocation on a pool_with_subpools. In this scenario there is a
-- master for each subpool.
if Is_Subpool_Allocation then
-- Case of an allocation without a Subpool_Handle. Dispatch to the
-- implementation of Default_Subpool_For_Pool.
if Context_Subpool = null then
Subpool :=
Default_Subpool_For_Pool
(Root_Storage_Pool_With_Subpools'Class (Pool));
-- Ensure proper ownership
if Subpool.Owner /=
Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
then
raise Program_Error with "incorrect owner of default subpool";
end if;
-- Allocation with a Subpool_Handle
else
Subpool := Context_Subpool;
-- Ensure proper ownership
if Subpool.Owner /=
Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
then
raise Program_Error with "incorrect owner of subpool";
end if;
end if;
Master := Subpool.Master'Unchecked_Access;
-- Allocation on a simple pool. In this scenario there is a master for
-- each access-to-controlled type. No context subpool should be present.
else
-- If the master is missing, then the expansion of the access type
-- failed to create one. This is a serious error.
if Context_Master = null then
raise Program_Error with "missing master in pool allocation";
-- If a subpool is present, then this is the result of erroneous
-- allocator expansion. This is not a serious error, but it should
-- still be detected.
elsif Context_Subpool /= null then
raise Program_Error with "subpool not required in pool allocation";
end if;
Master := Context_Master;
end if;
-- Step 2: Master-related runtime checks
-- Allocation of a descendant from [Limited_]Controlled, a class-wide
-- object or a record with controlled components.
if Is_Controlled then
-- Do not allow the allocation of controlled objects while the
-- associated master is being finalized.
if Master.Finalization_Started then
raise Program_Error with "allocation after finalization started";
end if;
-- The size must acount for the hidden header preceding the object
N_Size := Storage_Size + Header_Size;
-- Non-controlled allocation
else
N_Size := Storage_Size;
end if;
-- Step 3: Allocation of object
-- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
-- implementation of Allocate_From_Subpool.
if Is_Subpool_Allocation then
Allocate_From_Subpool
(Root_Storage_Pool_With_Subpools'Class (Pool),
N_Addr, N_Size, Alignment, Subpool);
-- For descendants of Root_Storage_Pool, dispatch to the implementation
-- of Allocate.
else
Allocate (Pool, N_Addr, N_Size, Alignment);
end if;
-- Step 4: Attachment
if Is_Controlled then
-- Map the allocated memory into a FM_Node record. This converts the
-- top of the allocated bits into a list header.
N_Ptr := Address_To_FM_Node_Ptr (N_Addr);
-- Check whether primitive Finalize_Address is available. If it is
-- not, then either the expansion of the designated type failed or
-- the expansion of the allocator failed. This is a serious error.
if Fin_Address = null then
raise Program_Error
with "primitive Finalize_Address not available";
end if;
N_Ptr.Finalize_Address := Fin_Address;
-- Prepend the allocated object to the finalization master
Attach (N_Ptr, Master.Objects'Unchecked_Access);
-- Move the address from the hidden list header to the start of the
-- object. This operation effectively hides the list header.
Addr := N_Addr + Header_Offset;
else
Addr := N_Addr;
end if;
end Allocate_Any_Controlled;
------------
-- Attach --
------------
procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
begin
Lock_Task.all;
L.Next.Prev := N;
N.Next := L.Next;
L.Next := N;
N.Prev := L;
Unlock_Task.all;
-- Note: No need to unlock in case of an exception because the above
-- code can never raise one.
end Attach;
-------------------------------
-- Deallocate_Any_Controlled --
-------------------------------
procedure Deallocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
Addr : System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True)
is
N_Addr : Address;
N_Ptr : FM_Node_Ptr;
N_Size : Storage_Count;
begin
-- Step 1: Detachment
if Is_Controlled then
-- Move the address from the object to the beginning of the list
-- header.
N_Addr := Addr - Header_Offset;
-- Convert the bits preceding the object into a list header
N_Ptr := Address_To_FM_Node_Ptr (N_Addr);
-- Detach the object from the related finalization master. This
-- action does not need to know the prior context used during
-- allocation.
Detach (N_Ptr);
-- The size of the deallocated object must include the size of the
-- hidden list header.
N_Size := Storage_Size + Header_Size;
else
N_Addr := Addr;
N_Size := Storage_Size;
end if;
-- Step 2: Deallocation
-- Dispatch to the proper implementation of Deallocate. This action
-- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
-- implementations.
Deallocate (Pool, N_Addr, N_Size, Alignment);
end Deallocate_Any_Controlled;
------------
-- Detach --
------------
procedure Detach (N : not null SP_Node_Ptr) is
begin
-- N must be attached to some list
pragma Assert (N.Next /= null and then N.Prev /= null);
Lock_Task.all;
N.Prev.Next := N.Next;
N.Next.Prev := N.Prev;
Unlock_Task.all;
-- Note: No need to unlock in case of an exception because the above
-- code can never raise one.
end Detach;
--------------
-- Finalize --
--------------
overriding procedure Finalize
(Pool : in out Root_Storage_Pool_With_Subpools)
is
Curr_Ptr : SP_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Next_Ptr : SP_Node_Ptr;
Raised : Boolean := False;
begin
-- Uninitialized pools do not have subpools and do not contain objects
-- of any kind.
if not Pool.Initialized then
return;
end if;
-- It is possible for multiple tasks to cause the finalization of a
-- common pool. Allow only one task to finalize the contents.
if Pool.Finalization_Started then
return;
end if;
-- Lock the pool to prevent the creation of additional subpools while
-- the available ones are finalized. The pool remains locked because
-- either it is about to be deallocated or the associated access type
-- is about to go out of scope.
Pool.Finalization_Started := True;
-- Skip the dummy head
Curr_Ptr := Pool.Subpools.Next;
while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
Next_Ptr := Curr_Ptr.Next;
-- Remove the subpool node from the subpool list
Detach (Curr_Ptr);
-- Finalize the current subpool
begin
Finalize_Subpool (Curr_Ptr.Subpool);
exception
when Fin_Occur : others =>
if not Raised then
Raised := True;
Save_Occurrence (Ex_Occur, Fin_Occur);
end if;
end;
-- Since subpool nodes are not allocated on the owner pool, they must
-- be explicitly destroyed.
Free (Curr_Ptr);
Curr_Ptr := Next_Ptr;
end loop;
-- If the finalization of a particular master failed, reraise the
-- exception now.
if Raised then
Reraise_Occurrence (Ex_Occur);
end if;
end Finalize;
----------------------
-- Finalize_Subpool --
----------------------
procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
begin
Finalize (Subpool.Master);
end Finalize_Subpool;
---------------------
-- Pool_Of_Subpool --
---------------------
function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
return access Root_Storage_Pool_With_Subpools'Class is
begin
return Subpool.Owner;
end Pool_Of_Subpool;
-------------------------
-- Set_Pool_Of_Subpool --
-------------------------
procedure Set_Pool_Of_Subpool
(Subpool : not null Subpool_Handle;
Pool : in out Root_Storage_Pool_With_Subpools'Class)
is
N_Ptr : SP_Node_Ptr;
begin
if not Pool.Initialized then
-- The dummy head must point to itself in both directions
Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
Pool.Initialized := True;
end if;
-- If the subpool is already owned, raise Program_Error. This is a
-- direct violation of the RM rules.
if Subpool.Owner /= null then
raise Program_Error with "subpool already belongs to a pool";
end if;
-- Prevent the creation of a new subpool while the owner is being
-- finalized. This is a serious error.
if Pool.Finalization_Started then
raise Program_Error
with "subpool creation after finalization started";
end if;
-- Create a subpool node, decorate it and associate it with the subpool
-- list of Pool.
N_Ptr := new SP_Node;
Subpool.Owner := Pool'Unchecked_Access;
N_Ptr.Subpool := Subpool;
Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
end Set_Pool_Of_Subpool;
end System.Storage_Pools.Subpools;

255
gcc/ada/s-stposu.ads Normal file
View File

@ -0,0 +1,255 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Finalization_Masters;
with System.Storage_Elements;
package System.Storage_Pools.Subpools is
pragma Preelaborate (System.Storage_Pools.Subpools);
type Root_Storage_Pool_With_Subpools is abstract
new Root_Storage_Pool with private;
-- The base for all implementations of Storage_Pool_With_Subpools. This
-- type is Limited_Controlled by derivation. To use subpools, an access
-- type must be associated with an implementation descending from type
-- Root_Storage_Pool_With_Subpools.
type Root_Subpool is abstract tagged limited private;
-- The base for all implementations of Subpool. Objects of this type are
-- managed by the pool_with_subpools.
type Subpool_Handle is access all Root_Subpool'Class;
for Subpool_Handle'Storage_Size use 0;
-- Since subpools are limited types by definition, a handle is instead used
-- to manage subpool abstractions.
overriding procedure Allocate
(Pool : in out Root_Storage_Pool_With_Subpools;
Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count);
-- Allocate an object described by Size_In_Storage_Elements and Alignment
-- on the default subpool of Pool.
procedure Allocate_From_Subpool
(Pool : in out Root_Storage_Pool_With_Subpools;
Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Subpool : not null Subpool_Handle)
is abstract;
-- ??? This precondition causes errors in simple tests, disabled for now
-- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
-- This routine requires implementation. Allocate an object described by
-- Size_In_Storage_Elements and Alignment on a subpool.
function Create_Subpool
(Pool : in out Root_Storage_Pool_With_Subpools;
Storage_Size : Storage_Elements.Storage_Count :=
Storage_Elements.Storage_Count'Last)
return not null Subpool_Handle
is abstract;
-- This routine requires implementation. Create a subpool within the given
-- pool_with_subpools.
overriding procedure Deallocate
(Pool : in out Root_Storage_Pool_With_Subpools;
Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is null;
procedure Deallocate_Subpool
(Pool : in out Root_Storage_Pool_With_Subpools;
Subpool : in out Subpool_Handle)
is abstract;
-- ??? This precondition causes errors in simple tests, disabled for now
-- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
-- This routine requires implementation. Reclaim the storage a particular
-- subpool occupies in a pool_with_subpools. This routine is called by
-- Ada.Unchecked_Deallocate_Subpool.
function Default_Subpool_For_Pool
(Pool : Root_Storage_Pool_With_Subpools)
return not null Subpool_Handle
is abstract;
-- This routine requires implementation. Returns a common subpool used for
-- allocations without Subpool_Handle_name in the allocator.
function Pool_Of_Subpool
(Subpool : not null Subpool_Handle)
return access Root_Storage_Pool_With_Subpools'Class;
-- Return the owner of the subpool
procedure Set_Pool_Of_Subpool
(Subpool : not null Subpool_Handle;
Pool : in out Root_Storage_Pool_With_Subpools'Class);
-- Set the owner of the subpool. This is intended to be called from
-- Create_Subpool or similar subpool constructors. Raises Program_Error
-- if the subpool already belongs to a pool.
private
-- Model
-- Pool_With_Subpools
-- +----> +---------------------+ <----+
-- | +---------- Subpools | |
-- | | +---------------------+ |
-- | | : User data : |
-- | | '.....................' |
-- | | |
-- | | SP_Node SP_Node |
-- | +-> +-------+ +-------+ |
-- | | Prev <-----> Prev | |
-- | +-------+ +-------+ |
-- | | Next <---->| Next | |
-- | +-------+ +-------+ |
-- | +----Subpool| |Subpool----+ |
-- | | +-------+ +-------+ | |
-- | | | |
-- | | Subpool Subpool | |
-- | +-> +-------+ +-------+ <-+ |
-- +------- Owner | | Owner -------+
-- +-------+ +-------+
-- +------------------- Master| | Master---------------+
-- | +-------+ +-------+ |
-- | : User : : User : |
-- | : Data : : Data : |
-- | '.......' '.......' |
-- | |
-- | Heap |
-- .. | ..................................................... | ..
-- : | | :
-- : | Object Object Object Object | :
-- : +-> +------+ +------+ +------+ +------+ <-+ :
-- : | Prev <--> Prev <--> Prev | | Prev | :
-- : +------+ +------+ +------+ +------+ :
-- : | Next <--> Next <--> Next | | Next | :
-- : +------+ +------+ +------+ +------+ :
-- : | FA | | FA | | FA | | FA | :
-- : +------+ +------+ +------+ +------+ :
-- : : : : : : : : : :
-- : : : : : : : : : :
-- : '......' '......' '......' '......' :
-- : :
-- '.............................................................'
-- Subpool list types. Each pool_with_subpools contains a list of subpools.
type SP_Node;
type SP_Node_Ptr is access all SP_Node;
type SP_Node is record
Prev : SP_Node_Ptr := null;
Next : SP_Node_Ptr := null;
Subpool : Subpool_Handle := null;
end record;
-- Root_Storage_Pool_With_Subpools internal structure
type Root_Storage_Pool_With_Subpools is abstract
new Root_Storage_Pool with
record
Initialized : Boolean := False;
pragma Atomic (Initialized);
-- Even though this type is derived from Limited_Controlled, overriding
-- Initialize would have no effect since the type is abstract. Routine
-- Set_Pool_Of_Subpool is tasked with the initialization of a pool with
-- subpools because it has to be called at some point. This flag is used
-- to prevent the resetting of the subpool chain.
Subpools : aliased SP_Node;
-- A doubly linked list of subpools
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- A flag which prevents the creation of new subpools while the master
-- pool is being finalized. The flag needs to be atomic because it is
-- accessed without Lock_Task / Unlock_Task.
end record;
type Any_Storage_Pool_With_Subpools_Ptr
is access all Root_Storage_Pool_With_Subpools'Class;
for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;
-- A subpool is an abstraction layer which sits on top of a pool. It
-- contains links to all controlled objects allocated on a particular
-- subpool.
type Root_Subpool is abstract tagged limited record
Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
-- A reference to the master pool_with_subpools
Master : aliased System.Finalization_Masters.Finalization_Master;
-- A collection of controlled objects
end record;
-- ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed
-- to Allocate_Any.
procedure Allocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
Context_Subpool : Subpool_Handle := null;
Context_Master : Finalization_Masters.Finalization_Master_Ptr := null;
Fin_Address : Finalization_Masters.Finalize_Address_Ptr := null;
Addr : out System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True);
-- Compiler interface. This version of Allocate handles all possible cases,
-- either on a pool or a pool_with_subpools.
procedure Deallocate_Any_Controlled
(Pool : in out Root_Storage_Pool'Class;
Addr : System.Address;
Storage_Size : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count;
Is_Controlled : Boolean := True);
-- Compiler interface. This version of Deallocate handles all possible
-- cases, either from a pool or a pool_with_subpools.
overriding procedure Finalize
(Pool : in out Root_Storage_Pool_With_Subpools);
-- Iterate over all subpools of Pool, detach them one by one and finalize
-- their masters. This action first detaches a controlled object from a
-- particular master, then invokes its Finalize_Address primitive.
procedure Finalize_Subpool (Subpool : not null Subpool_Handle);
-- Finalize the master of a subpool
end System.Storage_Pools.Subpools;

6
gcc/ada/sem_ch3.adb
View File

@ -1353,7 +1353,7 @@ package body Sem_Ch3 is
Set_Has_Task (T, False);
Set_Has_Controlled_Component (T, False);
-- Initialize Associated_Collection explicitly to Empty, to avoid
-- Initialize field Finalization_Master explicitly to Empty, to avoid
-- problems where an incomplete view of this entity has been previously
-- established by a limited with and an overlaid version of this field
-- (Stored_Constraint) was initialized for the incomplete view.
@ -1361,10 +1361,10 @@ package body Sem_Ch3 is
-- This reset is performed in most cases except where the access type
-- has been created for the purposes of allocating or deallocating a
-- build-in-place object. Such access types have explicitly set pools
-- and collections.
-- and finalization masters.
if No (Associated_Storage_Pool (T)) then
Set_Associated_Collection (T, Empty);
Set_Finalization_Master (T, Empty);
end if;
-- Ada 2005 (AI-231): Propagate the null-excluding and access-constant

9
gcc/ada/sem_ch6.adb
View File

@ -6080,14 +6080,13 @@ package body Sem_Ch6 is
end if;
-- In the case of functions whose result type needs finalization,
-- add an extra formal of type Ada.Finalization.Heap_Management.
-- Finalization_Collection_Ptr.
-- add an extra formal which represents the finalization master.
if Needs_BIP_Collection (E) then
if Needs_BIP_Finalization_Master (E) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalization_Collection_Ptr),
E, BIP_Formal_Suffix (BIP_Collection));
(E, RTE (RE_Finalization_Master_Ptr),
E, BIP_Formal_Suffix (BIP_Finalization_Master));
end if;
-- If the result type contains tasks, we have two extra formals:

1
gcc/ada/tbuild.adb
View File

@ -717,6 +717,7 @@ package body Tbuild is
(Def_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
pragma Assert (Nkind (Def_Id) in N_Entity);
Occurrence : Node_Id;
begin
Occurrence := New_Node (N_Identifier, Loc);