Commit e61fc983 by Arnaud Charlet

[multiple changes]

2014-11-20  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch6.adb (Expand_Call, Inlined_Subprogram): Do not suppress
	debugging information for a call to a predefined unit, if the
	call comes from source and the unit is in the Ada hierarchy.

2014-11-20  Bob Duff  <duff@adacore.com>

	* s-mudido.ads: Update signature of Create and Get_Last_CPU. Add
	CPU_Set, another Create, and Get_CPU_Set.
	* s-mudido.adb: Corresponding changes to the spec. New
	operations just raise an exception.  Also minor cleanup: use
	raise_expressions.
	* s-mudido-affinity.adb: Implementations of new operations from
	* s-mudido.ads, for the platforms that actually support processor
	affinity. The new Create (which takes a set) now does all the
	work; the old Create (which takes a range) now just calls the
	new one. Change error messages to reflect the fact that it's an
	arbitrary set, not just a range.

From-SVN: r217859
parent d18b1548
2014-11-20 Ed Schonberg <schonberg@adacore.com>
* exp_ch6.adb (Expand_Call, Inlined_Subprogram): Do not suppress
debugging information for a call to a predefined unit, if the
call comes from source and the unit is in the Ada hierarchy.
2014-11-20 Bob Duff <duff@adacore.com>
* s-mudido.ads: Update signature of Create and Get_Last_CPU. Add
CPU_Set, another Create, and Get_CPU_Set.
* s-mudido.adb: Corresponding changes to the spec. New
operations just raise an exception. Also minor cleanup: use
raise_expressions.
* s-mudido-affinity.adb: Implementations of new operations from
* s-mudido.ads, for the platforms that actually support processor
affinity. The new Create (which takes a set) now does all the
work; the old Create (which takes a range) now just calls the
new one. Change error messages to reflect the fact that it's an
arbitrary set, not just a range.
2014-11-20 Robert Dewar <dewar@adacore.com> 2014-11-20 Robert Dewar <dewar@adacore.com>
* exp_attr.adb: Minor reformatting. * exp_attr.adb: Minor reformatting.
......
...@@ -3720,7 +3720,17 @@ package body Exp_Ch6 is ...@@ -3720,7 +3720,17 @@ package body Exp_Ch6 is
(Unit_File_Name (Get_Source_Unit (Sloc (Subp)))) (Unit_File_Name (Get_Source_Unit (Sloc (Subp))))
and then In_Extended_Main_Source_Unit (N) and then In_Extended_Main_Source_Unit (N)
then then
Set_Needs_Debug_Info (Subp, False); -- We make an exception for calls to the Ada hierarchy if call
-- comes from source, because some user applications need the
-- debugging information for such calls.
if Comes_From_Source (Call_Node)
and then Name_Buffer (1 .. 2) = "a-"
then
null;
else
Set_Needs_Debug_Info (Subp, False);
end if;
end if; end if;
-- Front end expansion of simple functions returning unconstrained -- Front end expansion of simple functions returning unconstrained
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2011, Free Software Foundation, Inc. -- -- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -77,7 +77,7 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -77,7 +77,7 @@ package body System.Multiprocessors.Dispatching_Domains is
is is
Target : constant ST.Task_Id := Convert_Ids (T); Target : constant ST.Task_Id := Convert_Ids (T);
use type System.Tasking.Dispatching_Domain_Access; use type ST.Dispatching_Domain_Access;
begin begin
-- The exception Dispatching_Domain_Error is propagated if T is already -- The exception Dispatching_Domain_Error is propagated if T is already
...@@ -114,62 +114,49 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -114,62 +114,49 @@ package body System.Multiprocessors.Dispatching_Domains is
-- Create -- -- Create --
------------ ------------
function Create (First, Last : CPU) return Dispatching_Domain is function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
use type System.Tasking.Dispatching_Domain; begin
use type System.Tasking.Dispatching_Domain_Access; return Create ((First .. Last => True));
use type System.Tasking.Array_Allocated_Tasks; end Create;
use type System.Tasking.Task_Id;
function Create (Set : CPU_Set) return Dispatching_Domain is
Valid_System_Domain : constant Boolean := ST_DD : aliased constant ST.Dispatching_Domain
(First > CPU'First := ST.Dispatching_Domain (Set);
and then subtype Rng is CPU_Range range
not (System_Dispatching_Domain (CPU'First .. First - 1) = Get_First_CPU (ST_DD'Unrestricted_Access) ..
(CPU'First .. First - 1 => False))) Get_Last_CPU (ST_DD'Unrestricted_Access);
or else (Last < Number_Of_CPUs
and then not use type ST.Dispatching_Domain;
(System_Dispatching_Domain use type ST.Dispatching_Domain_Access;
(Last + 1 .. Number_Of_CPUs) = use type ST.Array_Allocated_Tasks;
(Last + 1 .. Number_Of_CPUs => False))); use type ST.Task_Id;
-- Constant that indicates whether there would exist a non-empty system
-- dispatching domain after the creation of this dispatching domain.
T : ST.Task_Id; T : ST.Task_Id;
New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all;
New_Domain : Dispatching_Domain; New_Domain : Dispatching_Domain;
begin begin
-- The range of processors for creating a dispatching domain must -- The set of processors for creating a dispatching domain must
-- comply with the following restrictions: -- comply with the following restrictions:
-- - Non-empty range -- - Not exceeding the range of available processors.
-- - Not exceeding the range of available processors -- - CPUs from the System_Dispatching_Domain.
-- - Range from the System_Dispatching_Domain -- - The calling task must be the environment task.
-- - Range does not contain a processor with a task assigned to it
-- - The allocation cannot leave System_Dispatching_Domain empty
-- - The calling task must be the environment task
-- - The call to Create must take place before the call to the main -- - The call to Create must take place before the call to the main
-- subprogram -- subprogram.
-- - Set does not contain a processor with a task assigned to it.
-- - The allocation cannot leave System_Dispatching_Domain empty.
if First > Last then -- Note that a previous version of the language forbade empty domains.
raise Dispatching_Domain_Error with "empty dispatching domain";
elsif Last > Number_Of_CPUs then if Rng'Last > Number_Of_CPUs then
raise Dispatching_Domain_Error with raise Dispatching_Domain_Error with
"CPU range not supported by the target"; "CPU not supported by the target";
elsif elsif (ST_DD and not ST.System_Domain (Rng)) /= (Rng => False) then
System_Dispatching_Domain (First .. Last) /= (First .. Last => True)
then
raise Dispatching_Domain_Error with raise Dispatching_Domain_Error with
"CPU range not currently in System_Dispatching_Domain"; "CPU not currently in System_Dispatching_Domain";
elsif
ST.Dispatching_Domain_Tasks (First .. Last) /= (First .. Last => 0)
then
raise Dispatching_Domain_Error with "CPU range has tasks assigned";
elsif not Valid_System_Domain then
raise Dispatching_Domain_Error with
"would leave System_Dispatching_Domain empty";
elsif Self /= Environment_Task then elsif Self /= Environment_Task then
raise Dispatching_Domain_Error with raise Dispatching_Domain_Error with
...@@ -177,10 +164,25 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -177,10 +164,25 @@ package body System.Multiprocessors.Dispatching_Domains is
elsif ST.Dispatching_Domains_Frozen then elsif ST.Dispatching_Domains_Frozen then
raise Dispatching_Domain_Error with raise Dispatching_Domain_Error with
"cannot create dispatching domain after call to main program"; "cannot create dispatching domain after call to main procedure";
end if;
for Proc in Rng loop
if ST_DD (Proc) and then
ST.Dispatching_Domain_Tasks (Proc) /= 0
then
raise Dispatching_Domain_Error with "CPU has tasks assigned";
end if;
end loop;
New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD;
if New_System_Domain = (New_System_Domain'Range => False) then
raise Dispatching_Domain_Error with
"would leave System_Dispatching_Domain empty";
end if; end if;
New_Domain := new ST.Dispatching_Domain'(First .. Last => True); New_Domain := new ST.Dispatching_Domain'(ST_DD);
-- At this point we need to fix the processors belonging to the system -- At this point we need to fix the processors belonging to the system
-- domain, and change the affinity of every task that has been created -- domain, and change the affinity of every task that has been created
...@@ -190,7 +192,8 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -190,7 +192,8 @@ package body System.Multiprocessors.Dispatching_Domains is
Lock_RTS; Lock_RTS;
System_Dispatching_Domain (First .. Last) := (First .. Last => False); ST.System_Domain (Rng) := New_System_Domain (Rng);
pragma Assert (ST.System_Domain.all = New_System_Domain);
-- Iterate the list of tasks belonging to the default system -- Iterate the list of tasks belonging to the default system
-- dispatching domain and set the appropriate affinity. -- dispatching domain and set the appropriate affinity.
...@@ -254,6 +257,15 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -254,6 +257,15 @@ package body System.Multiprocessors.Dispatching_Domains is
return Convert_Ids (T).Common.Base_CPU; return Convert_Ids (T).Common.Base_CPU;
end Get_CPU; end Get_CPU;
-----------------
-- Get_CPU_Set --
-----------------
function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
begin
return CPU_Set (Domain.all);
end Get_CPU_Set;
---------------------------- ----------------------------
-- Get_Dispatching_Domain -- -- Get_Dispatching_Domain --
---------------------------- ----------------------------
...@@ -278,16 +290,14 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -278,16 +290,14 @@ package body System.Multiprocessors.Dispatching_Domains is
end if; end if;
end loop; end loop;
-- Should never reach the following return return CPU'First;
return Domain'First;
end Get_First_CPU; end Get_First_CPU;
------------------ ------------------
-- Get_Last_CPU -- -- Get_Last_CPU --
------------------ ------------------
function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
begin begin
for Proc in reverse Domain'Range loop for Proc in reverse Domain'Range loop
if Domain (Proc) then if Domain (Proc) then
...@@ -295,9 +305,7 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -295,9 +305,7 @@ package body System.Multiprocessors.Dispatching_Domains is
end if; end if;
end loop; end loop;
-- Should never reach the following return return CPU_Range'First;
return Domain'Last;
end Get_Last_CPU; end Get_Last_CPU;
------------- -------------
...@@ -340,7 +348,7 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -340,7 +348,7 @@ package body System.Multiprocessors.Dispatching_Domains is
is is
Source_CPU : constant CPU_Range := T.Common.Base_CPU; Source_CPU : constant CPU_Range := T.Common.Base_CPU;
use type System.Tasking.Dispatching_Domain_Access; use type ST.Dispatching_Domain_Access;
begin begin
Write_Lock (T); Write_Lock (T);
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2011, Free Software Foundation, Inc. -- -- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -65,11 +65,18 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -65,11 +65,18 @@ package body System.Multiprocessors.Dispatching_Domains is
-- Create -- -- Create --
------------ ------------
function Create (First, Last : CPU) return Dispatching_Domain is function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
pragma Unreferenced (First, Last); pragma Unreferenced (First, Last);
begin begin
raise Dispatching_Domain_Error with "dispatching domains not supported"; return raise Dispatching_Domain_Error with
return System_Dispatching_Domain; "dispatching domains not supported";
end Create;
function Create (Set : CPU_Set) return Dispatching_Domain is
pragma Unreferenced (Set);
begin
return raise Dispatching_Domain_Error with
"dispatching domains not supported";
end Create; end Create;
----------------------------- -----------------------------
...@@ -107,6 +114,17 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -107,6 +114,17 @@ package body System.Multiprocessors.Dispatching_Domains is
return Not_A_Specific_CPU; return Not_A_Specific_CPU;
end Get_CPU; end Get_CPU;
-----------------
-- Get_CPU_Set --
-----------------
function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
pragma Unreferenced (Domain);
begin
return raise Dispatching_Domain_Error
with "dispatching domains not supported";
end Get_CPU_Set;
---------------------------- ----------------------------
-- Get_Dispatching_Domain -- -- Get_Dispatching_Domain --
---------------------------- ----------------------------
...@@ -134,7 +152,7 @@ package body System.Multiprocessors.Dispatching_Domains is ...@@ -134,7 +152,7 @@ package body System.Multiprocessors.Dispatching_Domains is
-- Get_Last_CPU -- -- Get_Last_CPU --
------------------ ------------------
function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
pragma Unreferenced (Domain); pragma Unreferenced (Domain);
begin begin
return Number_Of_CPUs; return Number_Of_CPUs;
......
...@@ -31,11 +31,17 @@ package System.Multiprocessors.Dispatching_Domains is ...@@ -31,11 +31,17 @@ package System.Multiprocessors.Dispatching_Domains is
System_Dispatching_Domain : constant Dispatching_Domain; System_Dispatching_Domain : constant Dispatching_Domain;
function Create (First, Last : CPU) return Dispatching_Domain; function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain;
function Get_First_CPU (Domain : Dispatching_Domain) return CPU; function Get_First_CPU (Domain : Dispatching_Domain) return CPU;
function Get_Last_CPU (Domain : Dispatching_Domain) return CPU; function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range;
type CPU_Set is array (CPU range <>) of Boolean;
function Create (Set : CPU_Set) return Dispatching_Domain;
function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set;
function Get_Dispatching_Domain function Get_Dispatching_Domain
(T : Ada.Task_Identification.Task_Id := (T : Ada.Task_Identification.Task_Id :=
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment