Skip to content

R
riscv-gcc-1
Commit 7882673f by Bob Duff Committed by Arnaud Charlet
Options

a-fihema.ads, [...] (Finalization_Collection): Avoid heap allocation for Objects component. 

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

	* a-fihema.ads, a-fihema.adb (Finalization_Collection): Avoid heap
	allocation for Objects component. This simplifies the code somewhat. It
	is also a little more efficient in the not-so-unusual case where there
	are no controlled objects allocated.
	Make Finalization_Started flag atomic.
	(Finalize): Avoid unnecessary detachment of items from the list.
	(pcol): Minor cleanup.

From-SVN: r177439
parent d34cd274
Showing with 43 additions and 96 deletions
gcc/ada/ChangeLog
2011-08-05 Bob Duff <duff@adacore.com>
* a-fihema.ads, a-fihema.adb (Finalization_Collection): Avoid heap
allocation for Objects component. This simplifies the code somewhat. It
is also a little more efficient in the not-so-unusual case where there
are no controlled objects allocated.
Make Finalization_Started flag atomic.
(Finalize): Avoid unnecessary detachment of items from the list.
(pcol): Minor cleanup.
2011-08-05 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Analyze_Formal_Package_Declaration): reject a formal
......
gcc/ada/a-fihema.adb
......@@ -31,7 +31,6 @@
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with System; use System;
with System.Address_Image;
......@@ -60,8 +59,6 @@ package body Ada.Finalization.Heap_Management is
procedure Detach (N : Node_Ptr);
-- Unhook a node from an arbitrary list
procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr);
---------------------------
-- Add_Offset_To_Address --
---------------------------
......@@ -117,7 +114,7 @@ package body Ada.Finalization.Heap_Management is
-- top of the allocated bits into a list header.
N_Ptr := Address_To_Node_Ptr (N_Addr);
Attach (N_Ptr, Collection.Objects);
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.
......@@ -251,54 +248,10 @@ package body Ada.Finalization.Heap_Management is
overriding procedure Finalize
(Collection : in out Finalization_Collection)
is
function Head (L : Node_Ptr) return Node_Ptr;
-- Return the node that comes after the dummy head
function Is_Dummy_Head (N : Node_Ptr) return Boolean;
-- Determine whether a node acts as a dummy head. Such nodes do not
-- have an actual "object" attached to them and point to themselves.
function Is_Empty_List (L : Node_Ptr) return Boolean;
-- Determine whether a list is empty
function Node_Ptr_To_Address (N : Node_Ptr) return Address;
-- Not the reverse of Address_To_Node_Ptr. Return the address of the
-- object following the list header.
----------
-- Head --
----------
function Head (L : Node_Ptr) return Node_Ptr is
begin
return L.Next;
end Head;
-------------------
-- Is_Dummy_Head --
-------------------
function Is_Dummy_Head (N : Node_Ptr) return Boolean is
begin
-- To be a dummy head, the node must point to itself in both
-- directions.
return
N.Next /= null
and then N.Next = N
and then N.Prev /= null
and then N.Prev = N;
end Is_Dummy_Head;
-------------------
-- Is_Empty_List --
-------------------
function Is_Empty_List (L : Node_Ptr) return Boolean is
begin
return L = null or else Is_Dummy_Head (L);
end Is_Empty_List;
-------------------------
-- Node_Ptr_To_Address --
-------------------------
......@@ -308,9 +261,8 @@ package body Ada.Finalization.Heap_Management is
return N.all'Address + Header_Offset;
end Node_Ptr_To_Address;
Curr_Ptr : Node_Ptr;
Curr_Ptr : Node_Ptr := Collection.Objects.Next; -- skip dummy head
Ex_Occur : Exception_Occurrence;
Next_Ptr : Node_Ptr;
Raised : Boolean := False;
-- Start of processing for Finalize
......@@ -323,28 +275,11 @@ package body Ada.Finalization.Heap_Management is
Collection.Finalization_Started := True;
while not Is_Empty_List (Collection.Objects) loop
-- Find the real head of the collection, skipping the dummy head
Curr_Ptr := Head (Collection.Objects);
-- If the dummy head is the only remaining node, all real objects
-- have already been detached and finalized.
if Is_Dummy_Head (Curr_Ptr) then
exit;
end if;
-- Store the next node now since the detachment will destroy the
-- reference to it.
Next_Ptr := Curr_Ptr.Next;
-- Remove the current node from the list
Detach (Curr_Ptr);
-- Go through the Objects list, and finalize each one. There is no need
-- to detach items from the list, because the whole collection is about
-- to go away.
while Curr_Ptr /= Collection.Objects'Unchecked_Access loop
-- ??? Kludge: Don't do anything until the proper place to set
-- primitive Finalize_Address has been determined.
......@@ -361,13 +296,9 @@ package body Ada.Finalization.Heap_Management is
end;
end if;
Curr_Ptr := Next_Ptr;
Curr_Ptr := Curr_Ptr.Next;
end loop;
-- Deallocate the dummy head
Free (Collection.Objects);
-- If the finalization of a particular node raised an exception, reraise
-- it after the remainder of the list has been finalized.
......@@ -384,12 +315,10 @@ package body Ada.Finalization.Heap_Management is
(Collection : in out Finalization_Collection)
is
begin
Collection.Objects := new Node;
-- The dummy head must point to itself in both directions
Collection.Objects.Next := Collection.Objects;
Collection.Objects.Prev := Collection.Objects;
Collection.Objects.Next := Collection.Objects'Unchecked_Access;
Collection.Objects.Prev := Collection.Objects'Unchecked_Access;
end Initialize;
----------
......@@ -397,6 +326,10 @@ package body Ada.Finalization.Heap_Management is
----------
procedure pcol (Collection : Finalization_Collection) is
Head : constant Node_Ptr := Collection.Objects'Unrestricted_Access;
-- "Unrestricted", because we're evilly getting access-to-variable of a
-- constant! OK for debugging code.
Head_Seen : Boolean := False;
N_Ptr : Node_Ptr;
......@@ -447,21 +380,18 @@ package body Ada.Finalization.Heap_Management is
-- - points to
-- (dummy head) - present if dummy head
N_Ptr := Collection.Objects;
N_Ptr := Head;
while N_Ptr /= null loop
while N_Ptr /= null loop -- Should never be null; we being defensive
Put_Line ("V");
-- The current node is the head. If we have already traversed the
-- chain, the head will be encountered again since the chain is
-- circular.
-- 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;
if N_Ptr = Collection.Objects then
if Head_Seen then
exit;
else
Head_Seen := True;
end if;
Head_Seen := True;
end if;
-- The current element is null. This should never happen since the
......@@ -488,7 +418,7 @@ package body Ada.Finalization.Heap_Management is
-- Detect the dummy head
if N_Ptr = Collection.Objects then
if N_Ptr = Head then
Put_Line (" (dummy head)");
else
Put_Line ("");
......
gcc/ada/a-fihema.ads
......@@ -93,11 +93,11 @@ package Ada.Finalization.Heap_Management is
overriding procedure Finalize
(Collection : in out Finalization_Collection);
-- Traverse the objects of Collection, invoking Finalize_Address on each of
-- them. In the end, the routine destroys its dummy head and tail.
-- them.
overriding procedure Initialize
(Collection : in out Finalization_Collection);
-- Create a new Collection by allocating a dummy head and tail
-- Initialize the finalization list to empty
procedure Set_Finalize_Address_Ptr
(Collection : in out Finalization_Collection;
......@@ -117,6 +117,11 @@ private
pragma No_Strict_Aliasing (Node_Ptr);
type Node is record
-- This should really be limited, but we can see the full view of
-- Limited_Controlled, which NOT limited. If it were limited, we could
-- default initialize here, and get rid of Initialize for
-- Finalization_Collection.
Prev : Node_Ptr;
Next : Node_Ptr;
end record;
......@@ -128,8 +133,10 @@ private
-- All objects and node headers are allocated on this underlying pool;
-- the collection is simply a wrapper around it.
Objects : Node_Ptr;
-- The head of a doubly linked list
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment