From 36f2e3d311c4679790f29c5cc08c33e1032987d3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 Oct 2015 12:10:20 +0200 Subject: [PATCH] [multiple changes] 2015-10-20 Ed Schonberg * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Generate freeze node for subprogram in Compile_Only mode. 2015-10-20 Dmitriy Anisimkov * 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 --- gcc/ada/ChangeLog | 11 +++++++++++ gcc/ada/a-contai.adb | 32 ++++++++----------------------- gcc/ada/a-contai.ads | 7 +++++-- gcc/ada/s-atocou-builtin.adb | 27 +++++++++++++++++++++----- gcc/ada/s-atocou-x86.adb | 31 +++++++++++++++++++++++------- gcc/ada/s-atocou.adb | 19 +++++++++++++++++- gcc/ada/s-atocou.ads | 37 +++++++++++++++++++++++++++++++----- gcc/ada/sem_ch6.adb | 17 ++++++++--------- 8 files changed, 128 insertions(+), 53 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d8bb5cb6512..948230a72ed 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2015-10-20 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Generate freeze + node for subprogram in Compile_Only mode. + +2015-10-20 Dmitriy Anisimkov + + * 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 * g-debpoo.ads (Dump): NEW print Debug_Pool statistics & main diff --git a/gcc/ada/a-contai.adb b/gcc/ada/a-contai.adb index 2cf589ca993..43b9473950e 100644 --- a/gcc/ada/a-contai.adb +++ b/gcc/ada/a-contai.adb @@ -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; diff --git a/gcc/ada/a-contai.ads b/gcc/ada/a-contai.ads index 02dc28f26a3..4b0b7953141 100644 --- a/gcc/ada/a-contai.ads +++ b/gcc/ada/a-contai.ads @@ -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 diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb index 55436aa8388..1df1c07b258 100644 --- a/gcc/ada/s-atocou-builtin.adb +++ b/gcc/ada/s-atocou-builtin.adb @@ -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 diff --git a/gcc/ada/s-atocou-x86.adb b/gcc/ada/s-atocou-x86.adb index b85b40274fa..bee6755485b 100644 --- a/gcc/ada/s-atocou-x86.adb +++ b/gcc/ada/s-atocou-x86.adb @@ -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 -- ---------------- diff --git a/gcc/ada/s-atocou.adb b/gcc/ada/s-atocou.adb index 51cc79ba59d..87e7818b820 100644 --- a/gcc/ada/s-atocou.adb +++ b/gcc/ada/s-atocou.adb @@ -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 -- ---------------- diff --git a/gcc/ada/s-atocou.ads b/gcc/ada/s-atocou.ads index a2e6d897efb..1147de7b45f 100644 --- a/gcc/ada/s-atocou.ads +++ b/gcc/ada/s-atocou.ads @@ -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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2151cf8b998..0d61181840d 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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;