Optimized version of Ada.Containers.Indefinite_Holders is used on
platforms which supports atomic operations.
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-10 Vadim Godunko <godu...@adacore.com>
* a-coinho-shared.ads, a-coinho-shared.adb: New file.
* s-atocou.ads: Add procedure to initialize counter.
* s-atocou.adb: Likewise.
* s-atocou-builtin.adb: Likewise.
* s-atocou-x86.adb: Likewise.
* gcc-interface/Makefile.in: Select special version of
Indefinite_Holders package on platforms where atomic built-ins
are supported.
Index: a-coinho-shared.adb
===================================================================
--- a-coinho-shared.adb (revision 0)
+++ a-coinho-shared.adb (revision 0)
@@ -0,0 +1,358 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2013, 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/>. --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Containers.Indefinite_Holders is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Holder) return Boolean is
+ begin
+ if Left.Reference = null and Right.Reference = null then
+ return True;
+
+ elsif Left.Reference /= null and Right.Reference /= null then
+ return Left.Reference.Element.all = Right.Reference.Element.all;
+
+ else
+ return False;
+ end if;
+ end "=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ overriding procedure Adjust (Container : in out Holder) is
+ begin
+ if Container.Reference /= null then
+ Reference (Container.Reference);
+ end if;
+
+ Container.Busy := 0;
+ end Adjust;
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Holder; Source : Holder) is
+ begin
+ if Target.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Target.Reference /= Source.Reference then
+ if Target.Reference /= null then
+ Unreference (Target.Reference);
+ end if;
+
+ Target.Reference := Source.Reference;
+
+ if Source.Reference /= null then
+ Reference (Target.Reference);
+ end if;
+ end if;
+ end Assign;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Holder) is
+ begin
+ if Container.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ Unreference (Container.Reference);
+ Container.Reference := null;
+ end Clear;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Holder) return Holder is
+ begin
+ if Source.Reference = null then
+ return (AF.Controlled with null, 0);
+ else
+ Reference (Source.Reference);
+
+ return (AF.Controlled with Source.Reference, 0);
+ end if;
+ end Copy;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Holder) return Element_Type is
+ begin
+ if Container.Reference = null then
+ raise Constraint_Error with "container is empty";
+ else
+ return Container.Reference.Element.all;
+ end if;
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ overriding procedure Finalize (Container : in out Holder) is
+ begin
+ if Container.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Container.Reference /= null then
+ Unreference (Container.Reference);
+ Container.Reference := null;
+ end if;
+ end Finalize;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Holder) return Boolean is
+ begin
+ return Container.Reference = null;
+ end Is_Empty;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Holder; Source : in out Holder) is
+ begin
+ if Target.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Source.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Target.Reference /= Source.Reference then
+ if Target.Reference /= null then
+ Unreference (Target.Reference);
+ end if;
+
+ Target.Reference := Source.Reference;
+ Source.Reference := null;
+ end if;
+ end Move;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : Holder;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+
+ begin
+ if Container.Reference = null then
+ raise Constraint_Error with "container is empty";
+ end if;
+
+ B := B + 1;
+
+ begin
+ Process (Container.Reference.Element.all);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ Container : out Holder)
+ is
+ begin
+ Clear (Container);
+
+ if not Boolean'Input (Stream) then
+ Container.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(Element_Type'Input (Stream)));
+ end if;
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ procedure Reference (Item : not null Shared_Holder_Access) is
+ begin
+ System.Atomic_Counters.Increment (Item.Counter);
+ end Reference;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Container : in out Holder;
+ New_Item : Element_Type)
+ is
+ -- Element allocator may need an accessibility check in case actual type
+ -- is class-wide or has access discriminants (RM 4.8(10.1) and
+ -- AI12-0035).
+
+ pragma Unsuppress (Accessibility_Check);
+
+ begin
+ if Container.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Container.Reference = null then
+ -- Holder is empty, allocate new Shared_Holder.
+
+ Container.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(New_Item));
+
+ elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then
+ -- Shared_Holder can be reused.
+
+ Free (Container.Reference.Element);
+ Container.Reference.Element := new Element_Type'(New_Item);
+
+ else
+ Unreference (Container.Reference);
+ Container.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(New_Item));
+ end if;
+ end Replace_Element;
+
+ ---------------
+ -- To_Holder --
+ ---------------
+
+ function To_Holder (New_Item : Element_Type) return Holder is
+ -- The element allocator may need an accessibility check in the case the
+ -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
+ -- and AI12-0035).
+
+ pragma Unsuppress (Accessibility_Check);
+
+ begin
+ return
+ (AF.Controlled with
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(New_Item)), 0);
+ end To_Holder;
+
+ -----------------
+ -- Unreference --
+ -----------------
+
+ procedure Unreference (Item : not null Shared_Holder_Access) is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access);
+
+ Aux : Shared_Holder_Access := Item;
+
+ begin
+ if System.Atomic_Counters.Decrement (Aux.Counter) then
+ Free (Aux.Element);
+ Free (Aux);
+ end if;
+ end Unreference;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : Holder;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+
+ begin
+ if Container.Reference = null then
+ raise Constraint_Error with "container is empty";
+ end if;
+
+ B := B + 1;
+
+ begin
+ Process (Container.Reference.Element.all);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ Container : Holder)
+ is
+ begin
+ Boolean'Output (Stream, Container.Reference = null);
+
+ if Container.Reference /= null then
+ Element_Type'Output (Stream, Container.Reference.Element.all);
+ end if;
+ end Write;
+
+end Ada.Containers.Indefinite_Holders;
Index: a-coinho-shared.ads
===================================================================
--- a-coinho-shared.ads (revision 0)
+++ a-coinho-shared.ads (revision 0)
@@ -0,0 +1,115 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013, 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/>. --
+------------------------------------------------------------------------------
+
+private with Ada.Finalization;
+private with Ada.Streams;
+private with System.Atomic_Counters;
+
+generic
+ type Element_Type (<>) is private;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Holders is
+ pragma Preelaborate (Indefinite_Holders);
+ pragma Remote_Types (Indefinite_Holders);
+
+ type Holder is tagged private;
+ pragma Preelaborable_Initialization (Holder);
+
+ Empty_Holder : constant Holder;
+
+ function "=" (Left, Right : Holder) return Boolean;
+
+ function To_Holder (New_Item : Element_Type) return Holder;
+
+ function Is_Empty (Container : Holder) return Boolean;
+
+ procedure Clear (Container : in out Holder);
+
+ function Element (Container : Holder) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Holder;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : Holder;
+ Process : not null access procedure (Element : Element_Type));
+ procedure Update_Element
+ (Container : Holder;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Assign (Target : in out Holder; Source : Holder);
+
+ function Copy (Source : Holder) return Holder;
+
+ procedure Move (Target : in out Holder; Source : in out Holder);
+
+private
+
+ package AF renames Ada.Finalization;
+
+ type Element_Access is access all Element_Type;
+
+ type Shared_Holder is record
+ Counter : System.Atomic_Counters.Atomic_Counter;
+ Element : Element_Access;
+ end record;
+
+ type Shared_Holder_Access is access all Shared_Holder;
+
+ procedure Reference (Item : not null Shared_Holder_Access);
+ -- Increment reference counter
+
+ procedure Unreference (Item : not null Shared_Holder_Access);
+ -- Decrement reference counter, deallocate Item when counter goes to zero
+
+ procedure Read
+ (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ Container : out Holder);
+
+ procedure Write
+ (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ Container : Holder);
+
+ type Holder is new Ada.Finalization.Controlled with record
+ Reference : Shared_Holder_Access;
+ Busy : Natural := 0;
+ end record;
+ for Holder'Read use Read;
+ for Holder'Write use Write;
+
+ overriding procedure Adjust (Container : in out Holder);
+ overriding procedure Finalize (Container : in out Holder);
+
+ Empty_Holder : constant Holder := (AF.Controlled with null, 0);
+
+end Ada.Containers.Indefinite_Holders;
Index: s-atocou.adb
===================================================================
--- s-atocou.adb (revision 203342)
+++ s-atocou.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011, AdaCore --
+-- Copyright (C) 2011-2013, AdaCore --
-- --
-- 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- --
@@ -57,6 +57,15 @@
raise Program_Error;
end Increment;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Item : out Atomic_Counter) is
+ begin
+ raise Program_Error;
+ end Initialize;
+
------------
-- Is_One --
------------
Index: s-atocou.ads
===================================================================
--- s-atocou.ads (revision 203342)
+++ s-atocou.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011, AdaCore --
+-- Copyright (C) 2011-2013, AdaCore --
-- --
-- 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- --
@@ -65,6 +65,12 @@
pragma Inline_Always (Is_One);
-- Returns True when value of the atomic counter is one.
+ procedure Initialize (Item : out Atomic_Counter);
+ pragma Inline_Always (Initialize);
+ -- Initialize counter by setting its value to one. This subprogram is
+ -- intended to be used in special cases when counter object can't be
+ -- initialized in standard way.
+
private
type Unsigned_32 is mod 2 ** 32;
Index: s-atocou-builtin.adb
===================================================================
--- s-atocou-builtin.adb (revision 203342)
+++ s-atocou-builtin.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011, AdaCore --
+-- Copyright (C) 2011-2013, AdaCore --
-- --
-- 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- --
@@ -72,6 +72,15 @@
Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1);
end Increment;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Item : out Atomic_Counter) is
+ begin
+ Item.Value := 1;
+ end Initialize;
+
------------
-- Is_One --
------------
Index: s-atocou-x86.adb
===================================================================
--- s-atocou-x86.adb (revision 203342)
+++ s-atocou-x86.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011, AdaCore --
+-- Copyright (C) 2011-2013, AdaCore --
-- --
-- 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- --
@@ -74,6 +74,15 @@
Volatile => True);
end Increment;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Item : out Atomic_Counter) is
+ begin
+ Item.Value := 1;
+ end Initialize;
+
------------
-- Is_One --
------------
Index: gcc-interface/Makefile.in
===================================================================
--- gcc-interface/Makefile.in (revision 203342)
+++ gcc-interface/Makefile.in (working copy)
@@ -408,6 +408,8 @@
# special version of Ada.Strings.Unbounded package can be used.
ATOMICS_TARGET_PAIRS = \
+ a-coinho.adb<a-coinho-shared.adb \
+ a-coinho.ads<a-coinho-shared.ads \
a-stunau.adb<a-stunau-shared.adb \
a-suteio.adb<a-suteio-shared.adb \
a-strunb.ads<a-strunb-shared.ads \
