FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

s-finimp.adb: (Finalize_List): Optimize in the no-abort case.

Browse source 
* s-finimp.adb: (Finalize_List): Optimize in the no-abort case.
	Minor reformatting.

From-SVN: r94822
This commit is contained in:
Arnaud Charlet 2005-02-10 14:56:20 +01:00
parent 340b490d0b
commit e703a483c4
1 changed files with 30 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

56
gcc/ada/s-finimp.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -38,6 +38,7 @@ with System.Storage_Elements;
with System.Soft_Links;
with Unchecked_Conversion;
with System.Restrictions;
package body System.Finalization_Implementation is
@ -137,10 +138,10 @@ package body System.Finalization_Implementation is
-- Start of processing for Adjust
begin
-- Adjust the components and their finalization pointers next.
-- We must protect against an exception in some call to Adjust, so
-- we keep pointing to the list of successfully adjusted components,
-- which can be finalized if an exception is raised.
-- Adjust the components and their finalization pointers next. We must
-- protect against an exception in some call to Adjust, so we keep
-- pointing to the list of successfully adjusted components, which can
-- be finalized if an exception is raised.
First_Comp := Object.F;
Object.F := null; -- nothing adjusted yet.
@ -155,8 +156,8 @@ package body System.Finalization_Implementation is
when others =>
-- Finalize those components that were successfully adjusted, and
-- propagate exception. The object itself is not yet attached to
-- global finalization list, so we cannot rely on the outer call
-- to Clean to take care of these components.
-- global finalization list, so we cannot rely on the outer call to
-- Clean to take care of these components.
Finalize (Object);
raise;
@ -178,10 +179,10 @@ package body System.Finalization_Implementation is
Obj.Next := L;
L := Obj'Unchecked_Access;
-- Dynamically allocated objects: they are attached to a doubly
-- linked list, so that an element can be finalized at any moment
-- by means of an unchecked deallocation. Attachement is
-- protected against multi-threaded access.
-- Dynamically allocated objects: they are attached to a doubly linked
-- list, so that an element can be finalized at any moment by means of
-- an unchecked deallocation. Attachement is protected against
-- multi-threaded access.
elsif Nb_Link = 2 then
@ -348,10 +349,10 @@ package body System.Finalization_Implementation is
procedure Detach_From_Final_List (Obj : in out Finalizable) is
begin
-- When objects are not properly attached to a doubly linked
-- list do not try to detach them. The only case where it can
-- happen is when dealing with Finalize_Storage_Only objects
-- which are not always attached.
-- When objects are not properly attached to a doubly linked list do
-- not try to detach them. The only case where it can happen is when
-- dealing with Finalize_Storage_Only objects which are not always
-- attached to the finalization list.
if Obj.Next /= null and then Obj.Prev /= null then
SSL.Lock_Task.all;
@ -414,17 +415,22 @@ package body System.Finalization_Implementation is
end record;
type Ptr is access all Fake_Exception_Occurence;
-- Let's get the current exception before starting to finalize in
-- order to check if we are in the abort case if an exception is
-- raised.
function To_Ptr is new
Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
X : constant Exception_Id :=
To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
X : Exception_Id := Null_Id;
begin
-- If abort is allowed, we get the current exception before starting
-- to finalize in order to check if we are in the abort case if an
-- exception is raised. When abort is not allowed, avoid accessing the
-- current exception since this can be a pretty costly operation in
-- programs using controlled types heavily.
if System.Restrictions.Abort_Allowed then
X := To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
end if;
while P /= null loop
Q := P.Next;
Finalize (P.all);
@ -447,7 +453,6 @@ package body System.Finalization_Implementation is
begin
Detach_From_Final_List (Obj);
Finalize (Obj);
exception
when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
end Finalize_One;
@ -461,7 +466,6 @@ package body System.Finalization_Implementation is
Offset : SSE.Storage_Offset := RC_Offset (The_Tag);
begin
-- Fetch the controller from the Parent or above if necessary
-- when there are no controller at this level
@ -484,7 +488,8 @@ package body System.Finalization_Implementation is
-- ancestor corresponding to the tag "The_Tag" and that its parent
-- is variable sized. We assume that the _controller is the first
-- compoment right after the parent.
-- ??? note that it may not be true if there are new discriminants.
-- ??? note that it may not be true if there are new discriminants
else -- Offset = -1
@ -527,7 +532,6 @@ package body System.Finalization_Implementation is
procedure Initialize (Object : in out Limited_Record_Controller) is
pragma Warnings (Off, Object);
begin
null;
end Initialize;