+2015-10-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Generate freeze
+ node for subprogram in Compile_Only mode.
+
+2015-10-20 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * s-atocou.adb, s-atocou.ads, a-contai.adb, a-contai.ads,
+ s-atocou-x86.adb, s-atocou-builtin.adb: Task safe over container
+ iterations.
+
2015-10-20 Philippe Gil <gil@adacore.com>
* g-debpoo.ads (Dump): NEW print Debug_Pool statistics & main
package body Generic_Implementation is
+ use SAC;
+
------------
-- Adjust --
------------
procedure Busy (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
- declare
- B : Natural renames T_Counts.Busy;
- begin
- B := B + 1;
- end;
+ Increment (T_Counts.Busy);
end if;
end Busy;
procedure Lock (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
- declare
- B : Natural renames T_Counts.Busy;
- L : Natural renames T_Counts.Lock;
- begin
- L := L + 1;
- B := B + 1;
- end;
+ Increment (T_Counts.Lock);
+ Increment (T_Counts.Busy);
end if;
end Lock;
procedure Unbusy (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
- declare
- B : Natural renames T_Counts.Busy;
- begin
- B := B - 1;
- end;
+ Decrement (T_Counts.Busy);
end if;
end Unbusy;
procedure Unlock (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
- declare
- B : Natural renames T_Counts.Busy;
- L : Natural renames T_Counts.Lock;
- begin
- L := L - 1;
- B := B - 1;
- end;
+ Decrement (T_Counts.Lock);
+ Decrement (T_Counts.Busy);
end if;
end Unlock;
-- checks.
private with Ada.Finalization;
+with System.Atomic_Counters;
package Ada.Containers is
pragma Pure;
private
+ package SAC renames System.Atomic_Counters;
+
Count_Type_Last : constant := Count_Type'Last;
-- Count_Type'Last as a universal_integer, so we can compare Index_Type
-- values against this without type conversions that might overflow.
type Tamper_Counts is record
- Busy : Natural := 0;
- Lock : Natural := 0;
+ Busy : aliased SAC.Atomic_Unsigned := 0;
+ Lock : aliased SAC.Atomic_Unsigned := 0;
end record;
-- Busy is positive when tampering with cursors is prohibited. Busy and
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2015, 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- --
package body System.Atomic_Counters is
procedure Sync_Add_And_Fetch
- (Ptr : access Unsigned_32;
- Value : Unsigned_32);
+ (Ptr : access Atomic_Unsigned;
+ Value : Atomic_Unsigned);
pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
function Sync_Sub_And_Fetch
- (Ptr : access Unsigned_32;
- Value : Unsigned_32) return Unsigned_32;
+ (Ptr : access Atomic_Unsigned;
+ Value : Atomic_Unsigned) return Atomic_Unsigned;
pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4");
---------------
-- Decrement --
---------------
+ procedure Decrement (Item : aliased in out Atomic_Unsigned) is
+ begin
+ if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then
+ null;
+ end if;
+ end Decrement;
+
+ function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is
+ begin
+ return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0;
+ end Decrement;
+
function Decrement (Item : in out Atomic_Counter) return Boolean is
begin
-- Note: the use of Unrestricted_Access here is required because we
-- Increment --
---------------
+ procedure Increment (Item : aliased in out Atomic_Unsigned) is
+ begin
+ Sync_Add_And_Fetch (Item'Unrestricted_Access, 1);
+ end Increment;
+
procedure Increment (Item : in out Atomic_Counter) is
begin
-- Note: the use of Unrestricted_Access here is required because we are
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2015, 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- --
-- Decrement --
---------------
- function Decrement (Item : in out Atomic_Counter) return Boolean is
+ function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is
Aux : Boolean;
begin
"lock%; decl" & ASCII.HT & "%0" & ASCII.LF & ASCII.HT
& "sete %1",
Outputs =>
- (Unsigned_32'Asm_Output ("=m", Item.Value),
+ (Atomic_Unsigned'Asm_Output ("=m", Item),
Boolean'Asm_Output ("=qm", Aux)),
- Inputs => Unsigned_32'Asm_Input ("m", Item.Value),
+ Inputs => Atomic_Unsigned'Asm_Input ("m", Item),
Volatile => True);
return Aux;
end Decrement;
+ procedure Decrement (Item : aliased in out Atomic_Unsigned) is
+ begin
+ if Decrement (Item) then
+ null;
+ end if;
+ end Decrement;
+
+ function Decrement (Item : in out Atomic_Counter) return Boolean is
+ begin
+ return Decrement (Item.Value);
+ end Decrement;
+
---------------
-- Increment --
---------------
- procedure Increment (Item : in out Atomic_Counter) is
+ procedure Increment (Item : aliased in out Atomic_Unsigned) is
begin
System.Machine_Code.Asm
(Template => "lock%; incl" & ASCII.HT & "%0",
- Outputs => Unsigned_32'Asm_Output ("=m", Item.Value),
- Inputs => Unsigned_32'Asm_Input ("m", Item.Value),
+ Outputs => Atomic_Unsigned'Asm_Output ("=m", Item),
+ Inputs => Atomic_Unsigned'Asm_Input ("m", Item),
Volatile => True);
end Increment;
+ procedure Increment (Item : in out Atomic_Counter) is
+ begin
+ Increment (Item.Value);
+ end Increment;
+
----------------
-- Initialize --
----------------
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2015, 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- --
return False;
end Decrement;
+ function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is
+ begin
+ -- Could not use Item := Item - 1; because it is disabled in spec.
+ Item := Atomic_Unsigned'Pred (Item);
+ return Item = 0;
+ end Decrement;
+
+ procedure Decrement (Item : aliased in out Atomic_Unsigned) is
+ begin
+ Item := Atomic_Unsigned'Pred (Item);
+ end Decrement;
+
---------------
-- Increment --
---------------
raise Program_Error;
end Increment;
+ procedure Increment (Item : aliased in out Atomic_Unsigned) is
+ begin
+ Item := Atomic_Unsigned'Succ (Item);
+ end Increment;
+
----------------
-- Initialize --
----------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2015, 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- --
package System.Atomic_Counters is
+ pragma Pure;
pragma Preelaborate;
type Atomic_Counter is limited private;
-- Atomic_Counter is declared as private limited type to provide highest
-- level of protection from unexpected use. All available operations are
-- declared below, and this set should be as small as possible.
+ -- Increment/Decrement operations for this type raise Program_Error on
+ -- platforms not supporting the atomic primitives.
procedure Increment (Item : in out Atomic_Counter);
pragma Inline_Always (Increment);
-- intended to be used in special cases when the counter object cannot be
-- initialized in standard way.
+ type Atomic_Unsigned is mod 2 ** 32 with Default_Value => 0, Atomic;
+ -- Modular compatible atomic unsigned type.
+ -- Increment/Decrement operations for this type are atomic only on
+ -- supported platforms. See top of the file.
+
+ procedure Increment
+ (Item : aliased in out Atomic_Unsigned) with Inline_Always;
+ -- Increments value of atomic counter
+
+ function Decrement
+ (Item : aliased in out Atomic_Unsigned) return Boolean with Inline_Always;
+
+ procedure Decrement
+ (Item : aliased in out Atomic_Unsigned) with Inline_Always;
+ -- Decrements value of atomic counter
+
+ -- The "+" and "-" abstract routine provided below to disable BT := BT + 1
+ -- constructions.
+
+ function "+"
+ (Left, Right : Atomic_Unsigned) return Atomic_Unsigned is abstract;
+
+ function "-"
+ (Left, Right : Atomic_Unsigned) return Atomic_Unsigned is abstract;
+
private
- type Unsigned_32 is mod 2 ** 32;
- type Atomic_Counter is limited record
- Value : aliased Unsigned_32 := 1;
+ type Atomic_Counter is record
+ Value : aliased Atomic_Unsigned := 1;
pragma Atomic (Value);
end record;
-- the freeze actions that include the bodies. In particular, extra
-- formals for accessibility or for return-in-place may need to be
-- generated. Freeze nodes, if any, are inserted before the current
- -- body. These freeze actions are also needed in ASIS mode to enable
- -- the proper back-annotations.
+ -- body. These freeze actions are also needed in ASIS mode and in
+ -- Compile_Only mode to enable the proper back-end type annotations.
+ -- They are necessary in any case to insure order of elaboration
+ -- in gigi.
if not Is_Frozen (Spec_Id)
- and then (Expander_Active or ASIS_Mode)
+ and then (Expander_Active
+ or else ASIS_Mode
+ or else (Operating_Mode = Check_Semantics
+ and then Serious_Errors_Detected = 0))
then
- -- Force the generation of its freezing node to ensure proper
- -- management of access types in the backend.
-
- -- This is definitely needed for some cases, but it is not clear
- -- why, to be investigated further???
-
Set_Has_Delayed_Freeze (Spec_Id);
Freeze_Before (N, Spec_Id);
end if;
projects / gcc.git / commitdiff