[multiple changes]
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. From-SVN: r229037
This commit is contained in:
parent
be7e4a402a
commit
36f2e3d311
|
@ -1,3 +1,14 @@
|
|||
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
|
||||
|
|
|
@ -29,6 +29,8 @@ package body Ada.Containers is
|
|||
|
||||
package body Generic_Implementation is
|
||||
|
||||
use SAC;
|
||||
|
||||
------------
|
||||
-- Adjust --
|
||||
------------
|
||||
|
@ -50,11 +52,7 @@ package body Ada.Containers is
|
|||
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;
|
||||
|
||||
|
@ -119,13 +117,8 @@ package body Ada.Containers is
|
|||
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;
|
||||
|
||||
|
@ -160,11 +153,7 @@ package body Ada.Containers is
|
|||
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;
|
||||
|
||||
|
@ -175,13 +164,8 @@ package body Ada.Containers is
|
|||
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;
|
||||
|
||||
|
|
|
@ -23,6 +23,7 @@ pragma Check_Name (Tampering_Check);
|
|||
-- checks.
|
||||
|
||||
private with Ada.Finalization;
|
||||
with System.Atomic_Counters;
|
||||
|
||||
package Ada.Containers is
|
||||
pragma Pure;
|
||||
|
@ -34,13 +35,15 @@ package Ada.Containers is
|
|||
|
||||
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
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -35,19 +35,31 @@
|
|||
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
|
||||
|
@ -62,6 +74,11 @@ package body System.Atomic_Counters is
|
|||
-- 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
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -44,7 +44,7 @@ package body System.Atomic_Counters is
|
|||
-- 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
|
||||
|
@ -53,27 +53,44 @@ package body System.Atomic_Counters is
|
|||
"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 --
|
||||
----------------
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -48,6 +48,18 @@ package body System.Atomic_Counters is
|
|||
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 --
|
||||
---------------
|
||||
|
@ -57,6 +69,11 @@ package body System.Atomic_Counters is
|
|||
raise Program_Error;
|
||||
end Increment;
|
||||
|
||||
procedure Increment (Item : aliased in out Atomic_Unsigned) is
|
||||
begin
|
||||
Item := Atomic_Unsigned'Succ (Item);
|
||||
end Increment;
|
||||
|
||||
----------------
|
||||
-- Initialize --
|
||||
----------------
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- 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- --
|
||||
|
@ -39,6 +39,7 @@
|
|||
|
||||
package System.Atomic_Counters is
|
||||
|
||||
pragma Pure;
|
||||
pragma Preelaborate;
|
||||
|
||||
type Atomic_Counter is limited private;
|
||||
|
@ -50,6 +51,8 @@ package System.Atomic_Counters is
|
|||
-- 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);
|
||||
|
@ -69,11 +72,35 @@ package System.Atomic_Counters is
|
|||
-- intended to be used in special cases when the counter object cannot be
|
||||
-- initialized in standard way.
|
||||
|
||||
private
|
||||
type Unsigned_32 is mod 2 ** 32;
|
||||
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.
|
||||
|
||||
type Atomic_Counter is limited record
|
||||
Value : aliased Unsigned_32 := 1;
|
||||
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 Atomic_Counter is record
|
||||
Value : aliased Atomic_Unsigned := 1;
|
||||
pragma Atomic (Value);
|
||||
end record;
|
||||
|
||||
|
|
|
@ -3215,18 +3215,17 @@ package body Sem_Ch6 is
|
|||
-- 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;
|
||||
|
|
Loading…
Reference in New Issue