diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-08-29 09:52:57 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2011-08-29 09:52:57 +0000 |
| commit | 57acff55fe858d74d732dbe8c9e4829ff4415aa3 (patch) | |
| tree | f70a40b65e9047bcf6e86a203d73f616a8c976dd | |
| parent | 20486e0be73a3de2b7afbf0e1309a928f166c893 (diff) | |
| download | gcc-57acff55fe858d74d732dbe8c9e4829ff4415aa3.tar.gz | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178183 138bc75d-0d04-0410-961f-82ee72b054a4
| -rw-r--r-- | gcc/ada/ChangeLog | 162 | ||||
| -rw-r--r-- | gcc/ada/Makefile.rtl | 4 | ||||
| -rw-r--r-- | gcc/ada/a-fihema.adb | 568 | ||||
| -rw-r--r-- | gcc/ada/a-fihema.ads | 161 | ||||
| -rw-r--r-- | gcc/ada/a-undesu.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/a-undesu.ads | 23 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 42 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 27 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 94 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 161 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 362 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.ads | 24 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 329 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 78 | ||||
| -rw-r--r-- | gcc/ada/s-finmas.adb | 214 | ||||
| -rw-r--r-- | gcc/ada/s-finmas.ads | 135 | ||||
| -rw-r--r-- | gcc/ada/s-stopoo.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/s-stopoo.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/s-stposu.adb | 473 | ||||
| -rw-r--r-- | gcc/ada/s-stposu.ads | 255 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/tbuild.adb | 1 |
30 files changed, 1912 insertions, 1396 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 24e400a154a..90001baf699 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 22eb02f18ef..16255b862b3 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -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) \ diff --git a/gcc/ada/a-fihema.adb b/gcc/ada/a-fihema.adb deleted file mode 100644 index 2eadd0cdf16..00000000000 --- a/gcc/ada/a-fihema.adb +++ /dev/null @@ -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; diff --git a/gcc/ada/a-fihema.ads b/gcc/ada/a-fihema.ads deleted file mode 100644 index 6e829d20517..00000000000 --- a/gcc/ada/a-fihema.ads +++ /dev/null @@ -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; diff --git a/gcc/ada/a-undesu.adb b/gcc/ada/a-undesu.adb new file mode 100644 index 00000000000..97c79157a8f --- /dev/null +++ b/gcc/ada/a-undesu.adb @@ -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; diff --git a/gcc/ada/a-undesu.ads b/gcc/ada/a-undesu.ads new file mode 100644 index 00000000000..b59888247ae --- /dev/null +++ b/gcc/ada/a-undesu.ads @@ -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); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index ffe43497df1..753dd4bfc91 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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 => diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 9e0ff33ddc6..6f061d198b9 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 9f182357ee7..a6890d72746 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 958033c3ca7..2ba20e5565f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index fb165cefff7..a4ef03ed6ce 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index cb6a6543ca4..5f8feb73bf0 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 0c50667d993..077ddeb9e19 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -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; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 0d81df24be7..acd64ca60ba 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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; - - begin - Proc_Id := - Make_Defining_Identifier (Loc, - Make_TSS_Name (Typ, TSS_Finalize_Address)); + Proc_Id := + Make_Defining_Identifier (Loc, + Make_TSS_Name (Typ, TSS_Finalize_Address)); - -- 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; + -- 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; - 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 -- -------------------------- diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index bcc5526897a..25b339559f9 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -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 -- -------------------------------------------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 64a6b6d3ffb..a23a923f418 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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); - end if; + -- a) Storage pool - -- Create the actuals for the call to Allocate / Deallocate + Append_To (Actuals, + New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc)); - Actuals := New_List ( - Collect_Act, - New_Reference_To (Addr_Id, Loc), - New_Reference_To (Size_Id, Loc), - New_Reference_To (Alig_Id, Loc)); + if Is_Allocate then - -- Generate a run-time check to determine whether a class-wide object - -- is truly controlled. + -- b) Subpool - 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; + 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; - begin - if Is_Allocate then - Temp := Find_Object (Expression (Expr)); + -- 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 - Temp := Expr; + 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; - -- Processing for generic actuals + -- d) Finalize_Address - if Is_Generic_Actual_Type (Desig_Typ) then - Flag_Expr := - New_Reference_To (Boolean_Literals - (Needs_Finalization (Base_Type (Desig_Typ))), Loc); + Fin_Addr_Id := Find_Finalize_Address (Desig_Typ); - -- Processing for subtype indications + 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; - 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); + -- e) Address + -- f) Storage_Size + -- g) Alignment - -- Generate a runtime check to test the controlled state of an - -- object for the purposes of allocation / deallocation. + 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)); - else - -- The following case arises when allocating through an - -- interface class-wide type, generate: - -- - -- Temp.all + -- h) Is_Controlled - if Is_RTE (Etype (Temp), RE_Tag_Ptr) then - Param := - Make_Explicit_Dereference (Loc, - Prefix => - Relocate_Node (Temp)); + -- Generate a run-time check to determine whether a class-wide object + -- is truly controlled. - -- 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 diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index c7b5b8f8e6c..7058ceb887d 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -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. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 462ed34c5a8..3532f096c98 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 1fdf36adff9..3b96918f928 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -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 -- diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 9742cb20b95..d4b07a97db1 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -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; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 5bfb7166801..48f4a33ab07 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb new file mode 100644 index 00000000000..7a5be2cd3c1 --- /dev/null +++ b/gcc/ada/s-finmas.adb @@ -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; diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads new file mode 100644 index 00000000000..26783d33172 --- /dev/null +++ b/gcc/ada/s-finmas.ads @@ -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; diff --git a/gcc/ada/s-stopoo.adb b/gcc/ada/s-stopoo.adb index c6674603366..3ac5beb176c 100644 --- a/gcc/ada/s-stopoo.adb +++ b/gcc/ada/s-stopoo.adb @@ -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; diff --git a/gcc/ada/s-stopoo.ads b/gcc/ada/s-stopoo.ads index c2d43f7c54c..1c4d12754a0 100644 --- a/gcc/ada/s-stopoo.ads +++ b/gcc/ada/s-stopoo.ads @@ -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; diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb new file mode 100644 index 00000000000..a4c0bb6c8ea --- /dev/null +++ b/gcc/ada/s-stposu.adb @@ -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; diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads new file mode 100644 index 00000000000..d8e58fb0797 --- /dev/null +++ b/gcc/ada/s-stposu.ads @@ -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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a3f5096376b..13e0fdbb0c0 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index f4934547ad0..cfb5b557a17 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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: diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index be4ca8aceab..a9a7757fc63 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -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); |