Skip to content

R
riscv-gcc-1
Commit 67645bde by Arnaud Charlet
Options

[multiple changes] 

2011-08-31  Jose Ruiz  <ruiz@adacore.com>

	* aspects.ads (Aspect_Id, Aspect_Argument, Aspect_Names): Add the
	dispatching domain aspect.
	* aspects.adb (Canonical_Aspect): Add entry for the dispatching domain
	aspect.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Analyze the
	Dispatching_Domain aspect in a similar way as we do for the Priority
	aspect.
	* exp_ch9.adb (Expand_N_Task_Type_Declaration): Add the
	Dispatching_Domain component if a Dispatching_Domain pragma or aspect
	is present.
	(Make_Task_Create_Call): Add the Dispatching_Domain when creating a task
	* par-prag.adb (Prag): Add Pragma_Dispatching_Domain as a known pragma.
	* sem_prag.adb (Analyze_Pragma): Check the correctness of a pragma
	Dispatching_Domain and add it to the task definition.
	(Sig_Flags): Add Pragma_Dispatching_Domain.
	* rtsfind.ads, rtsfind.adb (RTU_Id, RE_Id, Get_Unit_Name): Add the
	support to find the types Dispatching_Domain and
	Dispatching_Domain_Access.
	* sinfo.ads, sinfo.adb (Has_Pragma_Dispatching_Domain,
	Set_Has_Pragma_Dispatching_Domain): Add these subprograms to set and
	query the availability of a pragma Dispatching_Domain.
	* snames.ads-tmpl (Name_uDispatching_Domain): Add this name required by
	the expander to pass the Dispatching_Domain when creating a task.
	(Name_Dispatching_Domain): Add this new name for a pragma.
	(Pragma_Id): Add the new Pragma_Dispatching_Domain.
	* s-tassta.ads, s-tassta.adb (Create_Task): Set the domain to which the
	task has been allocated at creation time.
	* s-tarest.adb (Create_Restricted_Task): The dispatching domain using
	Ravenscar is always null.
	* s-taskin.ads, s-taskin.adb (Initialize_ATCB): Set the domain to which
	the task has been allocated at creation time.
	* s-tporft.adb (Register_Foreign_Thread): A foreign task will not have
	a specific dispatching domain.
	* s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-vxworks.adb,
	s-taprop-mingw.adb (Create_Task): Check whether both Dispatching_Domain
	and CPU are specified for the task, and the CPU value is not contained
	within the range of processors for the domain.

2011-08-31  Vincent Celier  <celier@adacore.com>

	* make.adb (Original_Gcc) : New constant String_Access.
	(Gnatmake): For VM targets, do not use VM version of the compiler if
	--GCC= has been specified.

2011-08-31  Thomas Quinot  <quinot@adacore.com>

	* sem_ch5.adb: Minor reformatting.

2011-08-31  Ed Schonberg  <schonberg@adacore.com>

	* exp_pakd.adb (Convert_To_PAT_Type): If prefix is a function call, do
	not reanalyze it.

2011-08-31  Bob Duff  <duff@adacore.com>

	* exp_ch4.adb (Expand_N_Selected_Component): Use the full type, in case
	the access type is private; we don't care about privacy in expansion.

2011-08-31  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Resolve_Aggregate): In an instance, ignore aggregate
	subcomponents tnat may be limited, because they originate in view
	conflicts. If the original aggregate is legal and the actuals are
	legal, the aggregate itself is legal.

From-SVN: r178371
parent b8789727
Showing with 385 additions and 54 deletions
gcc/ada/ChangeLog
2011-08-31 Jose Ruiz <ruiz@adacore.com>
* aspects.ads (Aspect_Id, Aspect_Argument, Aspect_Names): Add the
dispatching domain aspect.
* aspects.adb (Canonical_Aspect): Add entry for the dispatching domain
aspect.
* sem_ch13.adb (Analyze_Aspect_Specifications): Analyze the
Dispatching_Domain aspect in a similar way as we do for the Priority
aspect.
* exp_ch9.adb (Expand_N_Task_Type_Declaration): Add the
Dispatching_Domain component if a Dispatching_Domain pragma or aspect
is present.
(Make_Task_Create_Call): Add the Dispatching_Domain when creating a task
* par-prag.adb (Prag): Add Pragma_Dispatching_Domain as a known pragma.
* sem_prag.adb (Analyze_Pragma): Check the correctness of a pragma
Dispatching_Domain and add it to the task definition.
(Sig_Flags): Add Pragma_Dispatching_Domain.
* rtsfind.ads, rtsfind.adb (RTU_Id, RE_Id, Get_Unit_Name): Add the
support to find the types Dispatching_Domain and
Dispatching_Domain_Access.
* sinfo.ads, sinfo.adb (Has_Pragma_Dispatching_Domain,
Set_Has_Pragma_Dispatching_Domain): Add these subprograms to set and
query the availability of a pragma Dispatching_Domain.
* snames.ads-tmpl (Name_uDispatching_Domain): Add this name required by
the expander to pass the Dispatching_Domain when creating a task.
(Name_Dispatching_Domain): Add this new name for a pragma.
(Pragma_Id): Add the new Pragma_Dispatching_Domain.
* s-tassta.ads, s-tassta.adb (Create_Task): Set the domain to which the
task has been allocated at creation time.
* s-tarest.adb (Create_Restricted_Task): The dispatching domain using
Ravenscar is always null.
* s-taskin.ads, s-taskin.adb (Initialize_ATCB): Set the domain to which
the task has been allocated at creation time.
* s-tporft.adb (Register_Foreign_Thread): A foreign task will not have
a specific dispatching domain.
* s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-vxworks.adb,
s-taprop-mingw.adb (Create_Task): Check whether both Dispatching_Domain
and CPU are specified for the task, and the CPU value is not contained
within the range of processors for the domain.
2011-08-31 Vincent Celier <celier@adacore.com>
* make.adb (Original_Gcc) : New constant String_Access.
(Gnatmake): For VM targets, do not use VM version of the compiler if
--GCC= has been specified.
2011-08-31 Thomas Quinot <quinot@adacore.com>
* sem_ch5.adb: Minor reformatting.
2011-08-31 Ed Schonberg <schonberg@adacore.com>
* exp_pakd.adb (Convert_To_PAT_Type): If prefix is a function call, do
not reanalyze it.
2011-08-31 Bob Duff <duff@adacore.com>
* exp_ch4.adb (Expand_N_Selected_Component): Use the full type, in case
the access type is private; we don't care about privacy in expansion.
2011-08-31 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Resolve_Aggregate): In an instance, ignore aggregate
subcomponents tnat may be limited, because they originate in view
conflicts. If the original aggregate is legal and the actuals are
legal, the aggregate itself is legal.
2011-08-31 Matthew Heaney <heaney@adacore.com>
* a-rbtgbo.adb (Clear_Tree): Assert representation invariant for lock
......
gcc/ada/aspects.adb
......@@ -223,6 +223,7 @@ package body Aspects is
Aspect_Default_Iterator => Aspect_Default_Iterator,
Aspect_Default_Value => Aspect_Default_Value,
Aspect_Discard_Names => Aspect_Discard_Names,
Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate => Aspect_Predicate,
Aspect_External_Tag => Aspect_External_Tag,
Aspect_Favor_Top_Level => Aspect_Favor_Top_Level,
......
gcc/ada/aspects.ads
......@@ -53,6 +53,7 @@ package Aspects is
Aspect_Default_Component_Value,
Aspect_Default_Iterator,
Aspect_Default_Value,
Aspect_Dispatching_Domain,
Aspect_Dynamic_Predicate,
Aspect_External_Tag,
Aspect_Implicit_Dereference,
......@@ -190,6 +191,7 @@ package Aspects is
Aspect_Default_Component_Value => Expression,
Aspect_Default_Iterator => Name,
Aspect_Default_Value => Expression,
Aspect_Dispatching_Domain => Expression,
Aspect_Dynamic_Predicate => Expression,
Aspect_External_Tag => Expression,
Aspect_Implicit_Dereference => Name,
......@@ -250,6 +252,7 @@ package Aspects is
Aspect_Default_Value => Name_Default_Value,
Aspect_Default_Component_Value => Name_Default_Component_Value,
Aspect_Discard_Names => Name_Discard_Names,
Aspect_Dispatching_Domain => Name_Dispatching_Domain,
Aspect_Dynamic_Predicate => Name_Dynamic_Predicate,
Aspect_Elaborate_Body => Name_Elaborate_Body,
Aspect_External_Tag => Name_External_Tag,
......
gcc/ada/exp_ch4.adb
......@@ -7920,6 +7920,7 @@ package body Exp_Ch4 is
-- Insert explicit dereference if required
if Is_Access_Type (Ptyp) then
Set_Etype (P, Ptyp); -- in case it's private
Insert_Explicit_Dereference (P);
Analyze_And_Resolve (P, Designated_Type (Ptyp));
......
gcc/ada/exp_ch9.adb
......@@ -10422,12 +10422,14 @@ package body Exp_Ch9 is
-- values of this task. The general form of this type declaration is
-- type taskV (discriminants) is record
-- _Task_Id : Task_Id;
-- entry_family : array (bounds) of Void;
-- _Priority : Integer := priority_expression;
-- _Size : Size_Type := Size_Type (size_expression);
-- _Task_Info : Task_Info_Type := task_info_expression;
-- _CPU : Integer := cpu_range_expression;
-- _Task_Id : Task_Id;
-- entry_family : array (bounds) of Void;
-- _Priority : Integer := priority_expression;
-- _Size : Size_Type := size_expression;
-- _Task_Info : Task_Info_Type := task_info_expression;
-- _CPU : Integer := cpu_range_expression;
-- _Relative_Deadline : Time_Span := time_span_expression;
-- _Domain : Dispatching_Domain := dd_expression;
-- end record;
-- The discriminants are present only if the corresponding task type has
......@@ -10471,6 +10473,11 @@ package body Exp_Ch9 is
-- argument that was present in the pragma, and is used to provide the
-- Relative_Deadline parameter to the call to Create_Task.
-- The _Domain field is present only if a Dispatching_Domain pragma or
-- aspect appears in the task definition. The expression captures the
-- argument that was present in the pragma or aspect, and is used to
-- provide the Dispatching_Domain parameter to the call to Create_Task.
-- When a task is declared, an instance of the task value record is
-- created. The elaboration of this declaration creates the correct bounds
-- for the entry families, and also evaluates the size, priority, and
......@@ -10833,6 +10840,36 @@ package body Exp_Ch9 is
(Taskdef, Name_Relative_Deadline))))))));
end if;
-- Add the _Dispatching_Domain component if a Dispatching_Domain pragma
-- or aspect is present. If we are using a restricted run time this
-- component will not be added (dispatching domains are not allowed by
-- the Ravenscar profile).
if not Restricted_Profile
and then Present (Taskdef)
and then Has_Pragma_Dispatching_Domain (Taskdef)
then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uDispatching_Domain),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To
(RTE (RE_Dispatching_Domain_Access), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Dispatching_Domain_Access),
Relocate_Node (
Expression (First (
Pragma_Argument_Associations (
Find_Task_Or_Protected_Pragma
(Taskdef, Name_Dispatching_Domain))))))));
end if;
Insert_After (Size_Decl, Rec_Decl);
-- Analyze the record declaration immediately after construction,
......@@ -12782,6 +12819,31 @@ package body Exp_Ch9 is
New_Reference_To (RTE (RE_Time_Span_Zero), Loc));
end if;
-- Dispatching_Domain parameter. If no Dispatching_Domain pragma or
-- aspect is present, then the dispatching domain is null. If a
-- pragma or aspect is present, then the dispatching domain is taken
-- from the _Dispatching_Domain field of the task value record,
-- which was set from the pragma value. Note that this parameter
-- must not be generated for the restricted profiles since Ravenscar
-- does not allow dispatching domains.
-- Case where pragma or aspect Dispatching_Domain applies: use given
-- value.
if Present (Tdef) and then Has_Pragma_Dispatching_Domain (Tdef) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uInit),
Selector_Name =>
Make_Identifier (Loc, Name_uDispatching_Domain)));
-- No pragma or aspect Dispatching_Domain apply to the task
else
Append_To (Args, Make_Null (Loc));
end if;
-- Number of entries. This is an expression of the form:
-- n + _Init.a'Length + _Init.a'B'Length + ...
......
gcc/ada/exp_pakd.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, 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- --
......@@ -702,7 +702,9 @@ package body Exp_Pakd is
-- see Reset_Packed_Prefix. On the other hand, if the prefix is a simple
-- array reference, reanalysis can produce spurious type errors when the
-- PAT type is replaced again with the original type of the array. Same
-- for the case of a dereference. The following is correct and minimal,
-- for the case of a dereference. Ditto for function calls: expansion
-- may introduce additional actuals which will trigger errors if call
-- is reanalyzed. The following is correct and minimal,
-- but the handling of more complex packed expressions in actuals is
-- confused. Probably the problem only remains for actuals in calls.
......@@ -713,6 +715,7 @@ package body Exp_Pakd is
(Nkind (Aexp) = N_Indexed_Component
and then Is_Entity_Name (Prefix (Aexp)))
or else Nkind (Aexp) = N_Explicit_Dereference
or else Nkind (Aexp) = N_Function_Call
then
Set_Analyzed (Aexp);
end if;
......
gcc/ada/make.adb
......@@ -671,7 +671,12 @@ package body Make is
-- Compiler, Binder & Linker Data and Subprograms --
----------------------------------------------------
Gcc : String_Access := Program_Name ("gcc", "gnatmake");
Gcc : String_Access := Program_Name ("gcc", "gnatmake");
Original_Gcc : constant String_Access := Gcc;
-- Original_Gcc is used to check if Gcc has been modified by a switch
-- --GCC=, so that for VM platforms, it is not modified again, as it can
-- result in incorrect error messages if the compiler cannot be found.
Gnatbind : String_Access := Program_Name ("gnatbind", "gnatmake");
Gnatlink : String_Access := Program_Name ("gnatlink", "gnatmake");
-- Default compiler, binder, linker programs
......@@ -5973,10 +5978,6 @@ package body Make is
Gnatlink := Saved_Gnatlink;
end if;
Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all);
Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all);
Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all);
Bad_Compilation.Init;
-- If project files are used, create the mapping of all the sources, so
......@@ -6068,16 +6069,29 @@ package body Make is
-- instead.
Check_Object_Consistency := False;
Gcc := new String'("jvm-gnatcompile");
-- Do not modify Gcc is --GCC= was specified
if Gcc = Original_Gcc then
Gcc := new String'("jvm-gnatcompile");
end if;
when Targparm.CLI_Target =>
Gcc := new String'("dotnet-gnatcompile");
-- Do not modify Gcc is --GCC= was specified
if Gcc = Original_Gcc then
Gcc := new String'("dotnet-gnatcompile");
end if;
when Targparm.No_VM =>
raise Program_Error;
end case;
end if;
Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all);
Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all);
Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all);
-- If we have specified -j switch both from the project file
-- and on the command line, the one from the command line takes
-- precedence.
......
gcc/ada/par-prag.adb
......@@ -1128,6 +1128,7 @@ begin
Pragma_Default_Storage_Pool |
Pragma_Dimension |
Pragma_Discard_Names |
Pragma_Dispatching_Domain |
Pragma_Eliminate |
Pragma_Elaborate |
Pragma_Elaborate_All |
......
gcc/ada/rtsfind.adb
......@@ -321,6 +321,10 @@ package body Rtsfind is
elsif U_Id in System_Child then
Name_Buffer (7) := '.';
if U_Id in System_Multiprocessors_Child then
Name_Buffer (23) := '.';
end if;
if U_Id in System_Storage_Pools_Child then
Name_Buffer (21) := '.';
end if;
......
gcc/ada/rtsfind.ads
......@@ -371,6 +371,10 @@ package Rtsfind is
System_WWd_Enum,
System_WWd_Wchar,
-- Children of System.Multiprocessors
System_Multiprocessors_Dispatching_Domains,
-- Children of System.Storage_Pools
System_Storage_Pools_Subpools,
......@@ -440,6 +444,11 @@ package Rtsfind is
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
subtype System_Multiprocessors_Child is RTU_Id
range System_Multiprocessors_Dispatching_Domains ..
System_Multiprocessors_Dispatching_Domains;
-- Range of values for children of System.Multiprocessors
subtype System_Storage_Pools_Child is RTU_Id
range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools;
......@@ -1446,6 +1455,8 @@ package Rtsfind is
RE_Unspecified_CPU, -- System.Tasking
RE_Dispatching_Domain_Access, -- System.Tasking
RE_Abort_Defer, -- System.Soft_Links
RE_Abort_Undefer, -- System.Soft_Links
RE_Complete_Master, -- System.Soft_Links
......@@ -1588,6 +1599,8 @@ package Rtsfind is
RE_Width_Wide_Character, -- System.Wid_WChar
RE_Width_Wide_Wide_Character, -- System.Wid_WChar
RE_Dispatching_Domain, -- Dispatching_Domains
RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries
......@@ -2635,6 +2648,8 @@ package Rtsfind is
RE_Unspecified_CPU => System_Tasking,
RE_Dispatching_Domain_Access => System_Tasking,
RE_Abort_Defer => System_Soft_Links,
RE_Abort_Undefer => System_Soft_Links,
RE_Complete_Master => System_Soft_Links,
......@@ -2778,6 +2793,9 @@ package Rtsfind is
RE_Width_Wide_Character => System_Wid_WChar,
RE_Width_Wide_Wide_Character => System_Wid_WChar,
RE_Dispatching_Domain =>
System_Multiprocessors_Dispatching_Domains,
RE_Protected_Entry_Body_Array =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries =>
......
gcc/ada/s-taprop-linux.adb
......@@ -818,6 +818,18 @@ package body System.Task_Primitives.Operations is
use type System.Multiprocessors.CPU_Range;
begin
-- Check whether both Dispatching_Domain and CPU are specified for the
-- task, and the CPU value is not contained within the range of
-- processors for the domain.
if T.Common.Domain /= null and then
(T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU))
then
Succeeded := False;
return;
end if;
Adjusted_Stack_Size :=
Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
......
gcc/ada/s-taprop-mingw.adb
......@@ -895,9 +895,19 @@ package body System.Task_Primitives.Operations is
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
use type System.Multiprocessors.CPU_Range;
begin
-- Check whether both Dispatching_Domain and CPU are specified for the
-- task, and the CPU value is not contained within the range of
-- processors for the domain.
if T.Common.Domain /= null and then
(T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU))
then
Succeeded := False;
return;
end if;
pTaskParameter := To_Address (T);
Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
......
gcc/ada/s-taprop-solaris.adb
......@@ -976,6 +976,18 @@ package body System.Task_Primitives.Operations is
use System.Task_Info;
begin
-- Check whether both Dispatching_Domain and CPU are specified for the
-- task, and the CPU value is not contained within the range of
-- processors for the domain.
if T.Common.Domain /= null and then
(T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU))
then
Succeeded := False;
return;
end if;
Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size);
-- Since the initial signal mask of a thread is inherited from the
......
gcc/ada/s-taprop-vxworks.adb
......@@ -891,6 +891,18 @@ package body System.Task_Primitives.Operations is
Adjusted_Stack_Size : size_t;
begin
-- Check whether both Dispatching_Domain and CPU are specified for the
-- task, and the CPU value is not contained within the range of
-- processors for the domain.
if T.Common.Domain /= null and then
(T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU))
then
Succeeded := False;
return;
end if;
-- Ask for four extra bytes of stack space so that the ATCB pointer can
-- be stored below the stack limit, plus extra space for the frame of
-- Task_Wrapper. This is so the user gets the amount of stack requested
......
gcc/ada/s-tarest.adb
......@@ -505,11 +505,13 @@ package body System.Tasking.Restricted.Stages is
Write_Lock (Self_ID);
-- With no task hierarchy, the parent of all non-Environment tasks that
-- are created must be the Environment task
-- are created must be the Environment task. Dispatching domains are
-- not allowed in Ravenscar, so the dispatching domain parameter will
-- always be null.
Initialize_ATCB
(Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
Base_CPU, Task_Info, Size, Created_Task, Success);
Base_CPU, null, Task_Info, Size, Created_Task, Success);
-- If we do our job right then there should never be any failures, which
-- was probably said about the Titanic; so just to be safe, let's retain
......
gcc/ada/s-taskin.adb
......@@ -99,6 +99,7 @@ package body System.Tasking is
Elaborated : Access_Boolean;
Base_Priority : System.Any_Priority;
Base_CPU : System.Multiprocessors.CPU_Range;
Domain : Dispatching_Domain_Access;
Task_Info : System.Task_Info.Task_Info_Type;
Stack_Size : System.Parameters.Size_Type;
T : Task_Id;
......@@ -121,6 +122,7 @@ package body System.Tasking is
T.Common.Parent := Parent;
T.Common.Base_Priority := Base_Priority;
T.Common.Base_CPU := Base_CPU;
T.Common.Domain := Domain;
T.Common.Current_Priority := 0;
T.Common.Protected_Action_Nesting := 0;
T.Common.Call := null;
......@@ -209,7 +211,7 @@ package body System.Tasking is
T := STPO.New_ATCB (0);
Initialize_ATCB
(null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU,
Task_Info.Unspecified_Task_Info, 0, T, Success);
null, Task_Info.Unspecified_Task_Info, 0, T, Success);
pragma Assert (Success);
STPO.Initialize (T);
......
gcc/ada/s-taskin.ads
......@@ -1136,6 +1136,7 @@ package System.Tasking is
Elaborated : Access_Boolean;
Base_Priority : System.Any_Priority;
Base_CPU : System.Multiprocessors.CPU_Range;
Domain : Dispatching_Domain_Access;
Task_Info : System.Task_Info.Task_Info_Type;
Stack_Size : System.Parameters.Size_Type;
T : Task_Id;
......
gcc/ada/s-tassta.adb
......@@ -475,6 +475,7 @@ package body System.Tasking.Stages is
Task_Info : System.Task_Info.Task_Info_Type;
CPU : Integer;
Relative_Deadline : Ada.Real_Time.Time_Span;
Domain : Dispatching_Domain_Access;
Num_Entries : Task_Entry_Index;
Master : Master_Level;
State : Task_Procedure_Access;
......@@ -591,7 +592,7 @@ package body System.Tasking.Stages is
end if;
Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
Base_Priority, Base_CPU, Task_Info, Size, T, Success);
Base_Priority, Base_CPU, Domain, Task_Info, Size, T, Success);
if not Success then
Free (T);
......@@ -642,12 +643,13 @@ package body System.Tasking.Stages is
T.Common.Task_Image_Len := Len;
end if;
-- ??? For the moment the task inherits the dispatching domain of the
-- parent. It will change when support for the Dispatching_Domain
-- aspect will be added, because that will allow setting the domain
-- in the spec of the task.
-- The task inherits the dispatching domain of the parent only if no
-- specific domain has been defined in the spec of the task (using the
-- dispatching domain pragma or aspect).
if T.Common.Activator /= null then
if T.Common.Domain /= null then
null;
elsif T.Common.Activator /= null then
T.Common.Domain := T.Common.Activator.Common.Domain;
else
T.Common.Domain := System.Tasking.System_Domain;
......
gcc/ada/s-tassta.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- 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- --
......@@ -172,6 +172,7 @@ package System.Tasking.Stages is
Task_Info : System.Task_Info.Task_Info_Type;
CPU : Integer;
Relative_Deadline : Ada.Real_Time.Time_Span;
Domain : Dispatching_Domain_Access;
Num_Entries : Task_Entry_Index;
Master : Master_Level;
State : Task_Procedure_Access;
......@@ -195,6 +196,8 @@ package System.Tasking.Stages is
-- before setting the affinity at run time.
-- Relative_Deadline is the relative deadline associated with the created
-- task by means of a pragma Relative_Deadline, or 0.0 if none.
-- Domain is the dispatching domain associated with the created task by
-- means of a Dispatching_Domain pragma or aspect, or null if none.
-- State is the compiler generated task's procedure body
-- Discriminants is a pointer to a limited record whose discriminants
-- are those of the task to create. This parameter should be passed as
......
gcc/ada/s-tporft.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2011, Free Software Foundation, Inc. --
-- --
-- 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- --
......@@ -65,7 +65,7 @@ begin
System.Tasking.Initialize_ATCB
(Self_Id, null, Null_Address, Null_Task,
Foreign_Task_Elaborated'Access,
System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU,
System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, null,
Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded);
Unlock_RTS;
pragma Assert (Succeeded);
......
gcc/ada/sem_aggr.adb
......@@ -1052,8 +1052,14 @@ package body Sem_Aggr is
end if;
-- Ada 2005 (AI-287): Limited aggregates allowed
-- In an instance, ignore aggregate subcomponents tnat may be limited,
-- because they originate in view conflicts. If the original aggregate
-- is legal and the actuals are legal, the aggregate itself is legal.
if Is_Limited_Type (Typ) and then Ada_Version < Ada_2005 then
if Is_Limited_Type (Typ)
and then Ada_Version < Ada_2005
and then not In_Instance
then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
......
gcc/ada/sem_ch13.adb
......@@ -1149,29 +1149,36 @@ package body Sem_Ch13 is
pragma Assert (not Delay_Required);
when Aspect_Priority | Aspect_Interrupt_Priority => declare
Pname : Name_Id;
when Aspect_Priority |
Aspect_Interrupt_Priority |
Aspect_Dispatching_Domain =>
declare
Pname : Name_Id;
begin
if A_Id = Aspect_Priority then
Pname := Name_Priority;
begin
if A_Id = Aspect_Priority then
Pname := Name_Priority;
else
Pname := Name_Interrupt_Priority;
end if;
elsif A_Id = Aspect_Interrupt_Priority then
Pname := Name_Interrupt_Priority;
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Pname),
Pragma_Argument_Associations =>
New_List
(Make_Pragma_Argument_Association
(Sloc (Id), Expression => Relocate_Node (Expr))));
else
Pname := Name_Dispatching_Domain;
end if;
Set_From_Aspect_Specification (Aitem, True);
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Pname),
Pragma_Argument_Associations =>
New_List
(Make_Pragma_Argument_Association
(Sloc => Sloc (Id),
Expression => Relocate_Node (Expr))));
pragma Assert (not Delay_Required);
end;
Set_From_Aspect_Specification (Aitem, True);
pragma Assert (not Delay_Required);
end;
-- Aspects Pre/Post generate Precondition/Postcondition pragmas
-- with a first argument that is the expression, and a second
......@@ -1490,7 +1497,9 @@ package body Sem_Ch13 is
-- protected definition, which we need to create if it's
-- not there.
when Aspect_Priority | Aspect_Interrupt_Priority =>
when Aspect_Priority |
Aspect_Interrupt_Priority |
Aspect_Dispatching_Domain =>
declare
T : Node_Id; -- the type declaration
L : List_Id; -- list of decls of task/protected
......@@ -1503,7 +1512,9 @@ package body Sem_Ch13 is
T := N;
end if;
if Nkind (T) = N_Protected_Type_Declaration then
if Nkind (T) = N_Protected_Type_Declaration
and then A_Id /= Aspect_Dispatching_Domain
then
pragma Assert
(Present (Protected_Definition (T)));
......@@ -1520,8 +1531,7 @@ package body Sem_Ch13 is
End_Label => Empty));
end if;
L := Visible_Declarations
(Task_Definition (T));
L := Visible_Declarations (Task_Definition (T));
else
raise Program_Error;
......@@ -5880,6 +5890,9 @@ package body Sem_Ch13 is
when Aspect_Bit_Order =>
T := RTE (RE_Bit_Order);
when Aspect_Dispatching_Domain =>
T := RTE (RE_Dispatching_Domain);
when Aspect_External_Tag =>
T := Standard_String;
......
gcc/ada/sem_ch5.adb
......@@ -2058,7 +2058,7 @@ package body Sem_Ch5 is
end if;
-- Set kind of loop parameter, which may be used in
-- the subsequent analysis of of the condition in a
-- the subsequent analysis of the condition in a
-- quantified expression.
Set_Ekind (Id, E_Loop_Parameter);
......
gcc/ada/sem_prag.adb
......@@ -7866,6 +7866,54 @@ package body Sem_Prag is
end if;
end Discard_Names;
------------------------
-- Dispatching_Domain --
------------------------
-- pragma Dispatching_Domain (EXPRESSION);
when Pragma_Dispatching_Domain => Dispatching_Domain : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
begin
Ada_2012_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
-- This pragma is born obsolete, but not the aspect
if not From_Aspect_Specification (N) then
Check_Restriction
(No_Obsolescent_Features, Pragma_Identifier (N));
end if;
if Nkind (P) = N_Task_Definition then
Arg := Get_Pragma_Arg (Arg1);
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
-- Anything else is incorrect
else
Pragma_Misplaced;
end if;
if Has_Pragma_Dispatching_Domain (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_Dispatching_Domain (P, True);
if Nkind (P) = N_Task_Definition then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end if;
end Dispatching_Domain;
---------------
-- Elaborate --
---------------
......@@ -14462,6 +14510,7 @@ package body Sem_Prag is
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
Pragma_Discard_Names => 0,
Pragma_Dispatching_Domain => -1,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Pragma_Elaborate_Body => -1,
......
gcc/ada/sinfo.adb
......@@ -1471,6 +1471,14 @@ package body Sinfo is
return Flag14 (N);
end Has_Pragma_CPU;
function Has_Pragma_Dispatching_Domain
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Definition);
return Flag15 (N);
end Has_Pragma_Dispatching_Domain;
function Has_Pragma_Priority
(N : Node_Id) return Boolean is
begin
......@@ -4513,6 +4521,14 @@ package body Sinfo is
Set_Flag14 (N, Val);
end Set_Has_Pragma_CPU;
procedure Set_Has_Pragma_Dispatching_Domain
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Definition);
Set_Flag15 (N, Val);
end Set_Has_Pragma_Dispatching_Domain;
procedure Set_Has_Pragma_Priority
(N : Node_Id; Val : Boolean := True) is
begin
......
gcc/ada/sinfo.ads
......@@ -1145,6 +1145,11 @@ package Sinfo is
-- flag the presence of a CPU pragma in the declaration sequence (public
-- or private in the task case).
-- Has_Pragma_Dispatching_Domain (Flag15-Sem)
-- A flag present in N_Task_Definition nodes to flag the presence of a
-- Dispatching_Domain pragma in the declaration sequence (public or
-- private in the task case).
-- Has_Pragma_Suppress_All (Flag14-Sem)
-- This flag is set in an N_Compilation_Unit node if the Suppress_All
-- pragma appears anywhere in the unit. This accommodates the rather
......@@ -5061,6 +5066,7 @@ package Sinfo is
-- Has_Task_Name_Pragma (Flag8-Sem)
-- Has_Relative_Deadline_Pragma (Flag9-Sem)
-- Has_Pragma_CPU (Flag14-Sem)
-- Has_Pragma_Dispatching_Domain (Flag15-Sem)
--------------------
-- 9.1 Task Item --
......@@ -8493,6 +8499,9 @@ package Sinfo is
function Has_Pragma_CPU
(N : Node_Id) return Boolean; -- Flag14
function Has_Pragma_Dispatching_Domain
(N : Node_Id) return Boolean; -- Flag15
function Has_Pragma_Priority
(N : Node_Id) return Boolean; -- Flag6
......@@ -9462,6 +9471,9 @@ package Sinfo is
procedure Set_Has_Pragma_CPU
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_Has_Pragma_Dispatching_Domain
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Has_Pragma_Priority
(N : Node_Id; Val : Boolean := True); -- Flag6
......@@ -11875,6 +11887,7 @@ package Sinfo is
pragma Inline (Has_Self_Reference);
pragma Inline (Has_No_Elaboration_Code);
pragma Inline (Has_Pragma_CPU);
pragma Inline (Has_Pragma_Dispatching_Domain);
pragma Inline (Has_Pragma_Priority);
pragma Inline (Has_Pragma_Suppress_All);
pragma Inline (Has_Private_View);
......@@ -12194,6 +12207,7 @@ package Sinfo is
pragma Inline (Set_Has_Dynamic_Range_Check);
pragma Inline (Set_Has_No_Elaboration_Code);
pragma Inline (Set_Has_Pragma_CPU);
pragma Inline (Set_Has_Pragma_Dispatching_Domain);
pragma Inline (Set_Has_Pragma_Priority);
pragma Inline (Set_Has_Pragma_Suppress_All);
pragma Inline (Set_Has_Private_View);
......
gcc/ada/snames.ads-tmpl
......@@ -156,6 +156,7 @@ package Snames is
Name_uChain : constant Name_Id := N + $;
Name_uController : constant Name_Id := N + $;
Name_uCPU : constant Name_Id := N + $;
Name_uDispatching_Domain : constant Name_Id := N + $;
Name_uEntry_Bodies : constant Name_Id := N + $;
Name_uExpunge : constant Name_Id := N + $;
Name_uFinalizer : constant Name_Id := N + $;
......@@ -360,6 +361,7 @@ package Snames is
Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05
Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12
Name_Discard_Names : constant Name_Id := N + $;
Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12
Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT
Name_Eliminate : constant Name_Id := N + $; -- GNAT
Name_Extend_System : constant Name_Id := N + $; -- GNAT
......@@ -1523,6 +1525,7 @@ package Snames is
Pragma_Detect_Blocking,
Pragma_Default_Storage_Pool,
Pragma_Discard_Names,
Pragma_Dispatching_Domain,
Pragma_Elaboration_Checks,
Pragma_Eliminate,
Pragma_Extend_System,
......
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