OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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:
Arnaud Charlet 2015-10-20 12:10:20 +02:00
parent be7e4a402a
commit 36f2e3d311
8 changed files with 128 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/ada/ChangeLog
View File

@ -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

32
gcc/ada/a-contai.adb
View File

@ -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;

7
gcc/ada/a-contai.ads
View File

@ -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

27
gcc/ada/s-atocou-builtin.adb
View File

@ -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

31
gcc/ada/s-atocou-x86.adb
View File

@ -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 --
----------------

19
gcc/ada/s-atocou.adb
View File

@ -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 --
----------------

37
gcc/ada/s-atocou.ads
View File

@ -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;

17
gcc/ada/sem_ch6.adb
View File

@ -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;