+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_util.adb (Is_Post_State): A reference to a
+ generic in out parameter is considered a change in the post-state
+ of a subprogram.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Load_Parent_Of_Generic); When retrieving the
+ declaration of a subprogram instance within its wrapper package,
+ skip over null statements that may result from the rewriting of
+ ignored pragmas.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_attr.adb (Expand_Attribute_Reference, case 'Read):
+ If the type is an unchecked_union, replace the attribute with
+ a Raise_Program_Error (rather than inserting such before the
+ attribute reference) to handle properly the case where we are
+ processing a component of a larger record, and we need to prevent
+ further expansion for the unchecked union.
+ (Expand_Attribute_Reference, case 'Write): If the type is
+ an unchecked_union, check whether enclosing scope is a Write
+ subprogram. Replace attribute with a Raise_Program_Error if the
+ discriminants of the unchecked_union type have not default values
+ because such a use is erroneous..
+
+2017-04-25 Tristan Gingold <gingold@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Task_Type_Declaration):
+ Add relative_deadline to task record on edf profile.
+ (Make_Initialize_Protection): Pass deadline_floor value on edf profile.
+ (Make_Task_Create_Call): Pass relative_deadline value.
+ * par-prag.adb (Prag): Handle Pragma_Deadline_Floor.
+ * s-rident.ads (Profile_Name): Add GNAT_Ravenscar_EDF.
+ (Profile_Info): Add info for GNAT_Ravenscar_EDF.
+ * sem_prag.adb (Set_Ravenscar_Profile): Handle
+ GNAT_Ravenscar_EDF (set scheduling policy).
+ (Analyze_Pragma): Handle GNAT_Ravenscar_EDF profile and Deadline_Floor
+ pragma.
+ (Sig_Flags): Add choice for Pragma_Deadline_Floor.
+ * snames.ads-tmpl (Name_Deadline_Floor, Name_Gnat_Ravenscar_EDF):
+ New names.
+ (Pragma_Deadline_Floor): New pragma.
+ * targparm.adb (Get_Target_Parameters): Recognize
+ GNAT_Ravenscar_EDF profile.
+
2017-04-25 Arnaud Charlet <charlet@adacore.com trojanek>
* gnatvsn.ads (Library_Version): Bump to 8. Update comment.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- Ada 2005 (AI-216): Program_Error is raised when executing
-- the default implementation of the Read attribute of an
- -- Unchecked_Union type.
+ -- Unchecked_Union type. We replace the attribute with a
+ -- raise statement (rather than inserting it before) to handle
+ -- properly the case of an unchecked union that is a record
+ -- component.
if Is_Unchecked_Union (Base_Type (U_Type)) then
- Insert_Action (N,
+ Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
+ Set_Etype (N, B_Type);
+ return;
end if;
if Has_Discriminants (U_Type)
-- Unchecked_Union type. However, if the 'Write reference is
-- within the generated Output stream procedure, Write outputs
-- the components, and the default values of the discriminant
- -- are streamed by the Output procedure itself.
+ -- are streamed by the Output procedure itself. If there are
+ -- no default values this is also erroneous.
- if Is_Unchecked_Union (Base_Type (U_Type))
- and not Is_TSS (Current_Scope, TSS_Stream_Output)
- then
- Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
+ if Is_Unchecked_Union (Base_Type (U_Type)) then
+ if (not Is_TSS (Current_Scope, TSS_Stream_Output)
+ and not Is_TSS (Current_Scope, TSS_Stream_Write))
+ or else No (Discriminant_Default_Value
+ (First_Discriminant (U_Type)))
+ then
+ Rewrite (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+ Set_Etype (N, U_Type);
+ return;
+ end if;
end if;
if Has_Discriminants (U_Type)
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- Add the _Relative_Deadline component if a Relative_Deadline pragma is
-- present. If we are using a restricted run time this component will
- -- not be added (deadlines are not allowed by the Ravenscar profile).
+ -- not be added (deadlines are not allowed by the Ravenscar profile),
+ -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF
+ -- profile).
- if not Restricted_Profile
+ if (not Restricted_Profile or else Task_Dispatching_Policy = 'E')
and then Present (Taskdef)
and then Has_Relative_Deadline_Pragma (Taskdef)
then
New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
end if;
+ -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes
+
+ if Restricted_Profile and Task_Dispatching_Policy = 'E' then
+ Deadline_Floor : declare
+ Item : constant Node_Id :=
+ Get_Rep_Item
+ (Ptyp, Name_Deadline_Floor, Check_Parents => False);
+
+ Deadline : Node_Id;
+
+ begin
+ if Present (Item) then
+
+ -- Pragma Deadline_Floor
+
+ if Nkind (Item) = N_Pragma then
+ Deadline :=
+ Expression
+ (First (Pragma_Argument_Associations (Item)));
+
+ -- Attribute definition clause Deadline_Floor
+
+ else
+ pragma Assert
+ (Nkind (Item) = N_Attribute_Definition_Clause);
+
+ Deadline := Expression (Item);
+ end if;
+
+ Append_To (Args, Deadline);
+
+ -- Unusual case: default deadline
+
+ else
+ Append_To (Args,
+ New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
+ end if;
+ end Deadline_Floor;
+ end if;
+
-- Test for Compiler_Info parameter. This parameter allows entry body
-- procedures and barrier functions to be called from the runtime. It
-- is a pointer to the record generated by the compiler to represent
-- Priority parameter. Set to Unspecified_Priority unless there is a
-- Priority rep item, in which case we take the value from the rep item.
+ -- Not used on Ravenscar_EDF profile.
- if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
- Append_To (Args,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => Make_Identifier (Loc, Name_uPriority)));
- else
- Append_To (Args,
- New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
+ if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then
+ if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
+ Append_To (Args,
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => Make_Identifier (Loc, Name_uPriority)));
+ else
+ Append_To (Args,
+ New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
+ end if;
end if;
-- Optional Stack parameter
New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc));
end if;
- if not Restricted_Profile then
+ if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then
-- Deadline parameter. If no Relative_Deadline pragma is present,
-- then the deadline is Time_Span_Zero. If a pragma is present, then
Append_To (Args,
New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
end if;
+ end if;
+
+ if not Restricted_Profile then
-- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
-- present, then the dispatching domain is null. If a rep item is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
| Pragma_Component_Alignment
| Pragma_Controlled
| Pragma_Convention
+ | Pragma_Deadline_Floor
| Pragma_Debug_Policy
| Pragma_Depends
| Pragma_Detect_Blocking
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
Restricted_Tasking,
Restricted,
Ravenscar,
- GNAT_Extended_Ravenscar);
+ GNAT_Extended_Ravenscar,
+ GNAT_Ravenscar_EDF);
-- Names of recognized profiles. No_Profile is used to indicate that a
-- restriction came from pragma Restrictions[_Warning], as opposed to
-- pragma Profile[_Warning]. Restricted_Tasking is a non-user profile that
-- that also restrict protected types.
subtype Profile_Name_Actual is Profile_Name
- range No_Implementation_Extensions .. GNAT_Extended_Ravenscar;
+ range No_Implementation_Extensions .. Profile_Name'Last;
-- Actual used profile names
type Profile_Data is record
Value =>
(Max_Asynchronous_Select_Nesting => 0,
+ Max_Select_Alternatives => 0,
+ Max_Task_Entries => 0,
+ others => 0)),
+
+ -- GNAT_Ravenscar_EDF Profile
+
+ -- Note: the table entries here only represent the
+ -- required restriction profile for GNAT_Ravenscar_EDF.
+ -- The full GNAT_Ravenscar_EDF profile also requires:
+
+ -- pragma Dispatching_Policy (EDF_Across_Priorities);
+ -- pragma Locking_Policy (Ceiling_Locking);
+ -- pragma Detect_Blocking;
+
+ GNAT_Ravenscar_EDF =>
+
+ -- Restrictions for Ravenscar = Restricted profile ..
+
+ (Set =>
+ (No_Abort_Statements => True,
+ No_Asynchronous_Control => True,
+ No_Dynamic_Attachment => True,
+ No_Dynamic_Priorities => True,
+ No_Entry_Queue => True,
+ No_Local_Protected_Objects => True,
+ No_Protected_Type_Allocators => True,
+ No_Requeue_Statements => True,
+ No_Task_Allocators => True,
+ No_Task_Attributes_Package => True,
+ No_Task_Hierarchy => True,
+ No_Terminate_Alternatives => True,
+ Max_Asynchronous_Select_Nesting => True,
+ Max_Protected_Entries => True,
+ Max_Select_Alternatives => True,
+ Max_Task_Entries => True,
+
+ -- plus these additional restrictions:
+
+ No_Calendar => True,
+ No_Implicit_Heap_Allocations => True,
+ No_Local_Timing_Events => True,
+ No_Relative_Delay => True,
+ No_Select_Statements => True,
+ No_Specific_Termination_Handlers => True,
+ No_Task_Termination => True,
+ Simple_Barriers => True,
+ others => False),
+
+ -- Value settings for Ravenscar (same as Restricted)
+
+ Value =>
+ (Max_Asynchronous_Select_Nesting => 0,
+ Max_Protected_Entries => 1,
Max_Select_Alternatives => 0,
Max_Task_Entries => 0,
others => 0)));
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- package, in which case the usual generic rule applies.
declare
- Exp_Status : Boolean := True;
- Scop : Entity_Id;
+ Exp_Status : Boolean := True;
+ Scop : Entity_Id;
begin
-- Loop through scopes looking for generic package
-- Package instance
- if
- Nkind (Node (Decl)) = N_Package_Instantiation
+ if Nkind (Node (Decl)) = N_Package_Instantiation
then
Instantiate_Package_Body
(Info, Body_Optional => True);
-- these result in the corresponding pragmas,
-- inserted after the subprogram declaration.
-- They must be skipped as well when retrieving
- -- the desired spec. A direct link would be
- -- more robust ???
+ -- the desired spec. Some of them may have been
+ -- rewritten as null statements.
+ -- A direct link would be more robust ???
declare
Decl : Node_Id :=
(Specification (Info.Act_Decl))));
begin
while Nkind_In (Decl,
- N_Subprogram_Renaming_Declaration, N_Pragma)
+ N_Null_Statement,
+ N_Pragma,
+ N_Subprogram_Renaming_Declaration)
loop
Decl := Prev (Decl);
end loop;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
-- Activate the set of configuration pragmas and restrictions that make
- -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
- -- Ravenscar. N is the corresponding pragma node, which is used for
- -- error messages on any constructs violating the profile.
+ -- up the Profile. Profile must be either GNAT_Extended_Ravencar,
+ -- GNAT_Ravenscar_EDF or Ravenscar. N is the corresponding pragma node,
+ -- which is used for error messages on any constructs violating the
+ -- profile.
----------------------------------
-- Acquire_Warning_Match_String --
-- Set required policies
-- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
+ -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
+ -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
+ -- (For GNAT_Ravenscar_EDF profile)
-- pragma Locking_Policy (Ceiling_Locking)
-- Set Detect_Blocking mode
Pref_Id : Node_Id;
Sel_Id : Node_Id;
+ Profile_Dispatching_Policy : Character;
+
-- Start of processing for Set_Ravenscar_Profile
begin
+ -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
+
+ if Profile = GNAT_Ravenscar_EDF then
+ Profile_Dispatching_Policy := 'E';
+
-- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
+ else
+ Profile_Dispatching_Policy := 'F';
+ end if;
+
if Task_Dispatching_Policy /= ' '
- and then Task_Dispatching_Policy /= 'F'
+ and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
then
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Set_Error_Msg_To_Profile_Name;
-- name.
else
- Task_Dispatching_Policy := 'F';
+ Task_Dispatching_Policy := Profile_Dispatching_Policy;
if Task_Dispatching_Policy_Sloc /= System_Location then
Task_Dispatching_Policy_Sloc := Loc;
Record_Rep_Item (Ent, N);
end CPU;
+ --------------------
+ -- Deadline_Floor --
+ --------------------
+
+ -- pragma Deadline_Floor (time_span_EXPRESSION);
+
+ when Pragma_Deadline_Floor => Deadline_Floor : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+ Ent : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ 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_Time_Span));
+
+ -- Only protected types allowed
+
+ if Nkind (P) /= N_Protected_Definition then
+ Pragma_Misplaced;
+
+ else
+ Ent := Defining_Identifier (Parent (P));
+
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
+
+ Check_Duplicate_Pragma (Ent);
+ Record_Rep_Item (Ent, N);
+ end if;
+ end Deadline_Floor;
+
-----------
-- Debug --
-----------
elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
+ elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
+ Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
+
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions
(Restricted,
Pragma_Controlled => 0,
Pragma_Convention => 0,
Pragma_Convention_Identifier => 0,
+ Pragma_Deadline_Floor => -1,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => 0,
elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
Ent := Entity (N);
- -- The entity may be modifiable through an implicit
- -- dereference.
+ -- Treat an undecorated reference as OK
if No (Ent)
- or else Ekind (Ent) in Assignable_Kind
+
+ -- A reference to an assignable entity is considered a
+ -- change in the post-state of a subprogram.
+
+ or else Ekind_In (Ent, E_Generic_In_Out_Parameter,
+ E_In_Out_Parameter,
+ E_Out_Parameter,
+ E_Variable)
+
+ -- The reference may be modified through a dereference
+
or else (Is_Access_Type (Etype (Ent))
and then Nkind (Parent (N)) =
N_Selected_Component)
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- correctly recognize and process CPU. CPU is a standard Ada 2012
-- pragma.
+ Name_Deadline_Floor : constant Name_Id := N + $; -- GNAT
Name_Debug : constant Name_Id := N + $; -- GNAT
Name_Default_Initial_Condition : constant Name_Id := N + $; -- GNAT
Name_Depends : constant Name_Id := N + $; -- GNAT
Name_General : constant Name_Id := N + $;
Name_Gnat : constant Name_Id := N + $;
Name_Gnat_Extended_Ravenscar : constant Name_Id := N + $;
+ Name_Gnat_Ravenscar_EDF : constant Name_Id := N + $;
Name_Gnatprove : constant Name_Id := N + $;
Name_GPL : constant Name_Id := N + $;
Name_High_Order_First : constant Name_Id := N + $;
Pragma_CPP_Constructor,
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
+ Pragma_Deadline_Floor,
Pragma_Debug,
Pragma_Default_Initial_Condition,
Pragma_Depends,
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2017, 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- --
Set_Profile_Restrictions (GNAT_Extended_Ravenscar);
Opt.Task_Dispatching_Policy := 'F';
Opt.Locking_Policy := 'C';
- P := P + 27;
+ P := P + 41;
+ goto Line_Loop_Continue;
+
+ -- Test for pragma Profile (GNAT_Ravenscar_EDF);
+
+ elsif System_Text (P .. P + 35) =
+ "pragma Profile (GNAT_Ravenscar_EDF);"
+ then
+ Set_Profile_Restrictions (GNAT_Ravenscar_EDF);
+ Opt.Task_Dispatching_Policy := 'E';
+ Opt.Locking_Policy := 'C';
+ P := P + 36;
goto Line_Loop_Continue;
-- Test for pragma Profile (Restricted);
projects / gcc.git / commitdiff