-- See documentation in backend for further details.
-- Has_Nested_Subprogram (Flag282)
--- Defined in subprogram entities. Set for a subprogram which contains at
--- least one nested subprogram.
+-- Defined in subprogram entities. Set for a subprogram which contains at
+-- least one nested subprogram.
-- Has_Non_Limited_View (synth)
-- Defined in E_Incomplete_Type, E_Incomplete_Subtype, E_Class_Wide_Type,
-- E is a type, it has components that have no static initialization.
-- if E is an entity, its initial expression is not compile-time known.
- function Init_Formals (Typ : Entity_Id) return List_Id;
+ function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id;
-- This function builds the list of formals for an initialization routine.
-- The first formal is always _Init with the given type. For task value
-- record types and types containing tasks, three additional formals are
- -- added:
+ -- added and Proc_Id is decorated with attribute Has_Master_Entity:
--
-- _Master : Master_Id
-- _Chain : in out Activation_Chain
end if;
Body_Stmts := Init_One_Dimension (1);
- Parameters := Init_Formals (A_Type);
+ Parameters := Init_Formals (A_Type, Proc_Id);
Discard_Node (
Make_Subprogram_Body (Loc,
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
- Parameters := Init_Formals (Rec_Type);
+ Parameters := Init_Formals (Rec_Type, Proc_Id);
Append_List_To (Parameters,
Build_Discriminant_Formals (Rec_Type, True));
-- record parameter for an entry declaration. No master is created
-- for such a type.
- if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
+ if Has_Task (Desig_Typ) then
Build_Master_Entity (Ptr_Typ);
Build_Master_Renaming (Ptr_Typ);
-- Suppress the master creation for access types created for entry
-- formal parameters (parameter block component types). Seems like
-- suppression should be more general for compiler-generated types,
- -- but testing Comes_From_Source, like the code above does, may be
- -- too general in this case (affects some test output)???
+ -- but testing Comes_From_Source may be too general in this case
+ -- (affects some test output)???
elsif not Is_Param_Block_Component_Type (Ptr_Typ)
and then Is_Limited_Class_Wide_Type (Desig_Typ)
- and then Tasking_Allowed
then
Build_Class_Wide_Master (Ptr_Typ);
end if;
Init_After := Make_Shared_Var_Procs (N);
end if;
- -- If tasks being declared, make sure we have an activation chain
+ -- If tasks are being declared, make sure we have an activation chain
-- defined for the tasks (has no effect if we already have one), and
- -- also that a Master variable is established and that the appropriate
- -- enclosing construct is established as a task master.
+ -- also that a Master variable is established (and that the appropriate
+ -- enclosing construct is established as a task master).
- if Has_Task (Typ) then
+ if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
Build_Activation_Chain_Entity (N);
- Build_Master_Entity (Def_Id);
+
+ if Has_Task (Typ) then
+ Build_Master_Entity (Def_Id);
+
+ -- Handle objects initialized with BIP function calls
+
+ elsif Present (Expr) then
+ declare
+ Expr_Q : Node_Id := Expr;
+
+ begin
+ if Nkind (Expr) = N_Qualified_Expression then
+ Expr_Q := Expression (Expr);
+ end if;
+
+ if Is_Build_In_Place_Function_Call (Expr_Q)
+ or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
+ or else
+ (Nkind (Expr_Q) = N_Reference
+ and then
+ Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
+ then
+ Build_Master_Entity (Def_Id);
+ end if;
+ end;
+ end if;
end if;
-- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
-- of the stacks in this scenario, the stacks of the first array are
-- not counted.
- if Has_Task (Typ)
+ if (Has_Task (Typ) or else Might_Have_Tasks (Typ))
and then not Restriction_Active (No_Secondary_Stack)
and then (Restriction_Active (No_Implicit_Heap_Allocations)
or else Restriction_Active (No_Implicit_Task_Allocations))
-- Init_Formals --
------------------
- function Init_Formals (Typ : Entity_Id) return List_Id is
+ function Init_Formals (Typ : Entity_Id; Proc_Id : Entity_Id) return List_Id
+ is
Loc : constant Source_Ptr := Sloc (Typ);
Unc_Arr : constant Boolean :=
Is_Array_Type (Typ) and then not Is_Constrained (Typ);
or else (Is_Record_Type (Typ)
and then Is_Protected_Record_Type (Typ));
With_Task : constant Boolean :=
- Has_Task (Typ)
- or else (Is_Record_Type (Typ)
- and then Is_Task_Record_Type (Typ));
+ not Global_No_Tasking
+ and then
+ (Has_Task (Typ)
+ or else (Is_Record_Type (Typ)
+ and then Is_Task_Record_Type (Typ)));
Formals : List_Id;
begin
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
+ Set_Has_Master_Entity (Proc_Id);
+
-- Add _Chain (not done for sequential elaboration policy, see
-- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
-- The designated type was an incomplete type, and the
-- access type did not get expanded. Salvage it now.
- if not Restriction_Active (No_Task_Hierarchy) then
- if Present (Parent (Base_Type (PtrT))) then
- Expand_N_Full_Type_Declaration
- (Parent (Base_Type (PtrT)));
+ if Present (Parent (Base_Type (PtrT))) then
+ Expand_N_Full_Type_Declaration
+ (Parent (Base_Type (PtrT)));
- -- The only other possibility is an itype. For this
- -- case, the master must exist in the context. This is
- -- the case when the allocator initializes an access
- -- component in an init-proc.
+ -- The only other possibility is an itype. For this
+ -- case, the master must exist in the context. This is
+ -- the case when the allocator initializes an access
+ -- component in an init-proc.
- else
- pragma Assert (Is_Itype (PtrT));
- Build_Master_Renaming (PtrT, N);
- end if;
+ else
+ pragma Assert (Is_Itype (PtrT));
+ Build_Master_Renaming (PtrT, N);
end if;
end if;
-- rather than some outer chain.
begin
- if Has_Task (Result_Subt) then
+ if Has_Task (Result_Subt) or else Might_Have_Tasks (Result_Subt) then
Actions := New_List;
Build_Task_Allocate_Block_With_Init_Stmts
(Actions, Allocator, Init_Stmts => New_List (Assign));
Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);
Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));
Set_Etype (Anon_Type, Anon_Type);
+ Build_Class_Wide_Master (Anon_Type);
Tmp_Decl :=
Make_Object_Declaration (Loc,
Analyze_And_Resolve (Allocator, Acc_Type);
end Make_CPP_Constructor_Call_In_Allocator;
+ ----------------------
+ -- Might_Have_Tasks --
+ ----------------------
+
+ function Might_Have_Tasks (Typ : Entity_Id) return Boolean is
+ begin
+ return not Global_No_Tasking
+ and then not No_Run_Time_Mode
+ and then Is_Class_Wide_Type (Typ)
+ and then Is_Limited_Record (Typ);
+ end Might_Have_Tasks;
+
----------------------------
-- Needs_BIP_Task_Actuals --
----------------------------
pragma Assert (Is_Build_In_Place_Function (Func_Id));
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
begin
- return Has_Task (Func_Typ);
+ return not Global_No_Tasking
+ and then (Has_Task (Func_Typ) or else Might_Have_Tasks (Func_Typ));
end Needs_BIP_Task_Actuals;
-----------------------------------
-- the constructor, and the allocator is rewritten to refer to that access
-- object. Function_Call must denote a call to a CPP_Constructor function.
+ function Might_Have_Tasks (Typ : Entity_Id) return Boolean;
+ -- Return True if Typ is a limited class-wide type (or subtype), since it
+ -- might have task components.
+
function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Return True if the function needs an implicit
-- BIP_Alloc_Form parameter (see type BIP_Formal_Kind).
-- Start of processing for Build_Activation_Chain_Entity
begin
+ -- No action needed if the run-time has no tasking support
+
+ if Global_No_Tasking then
+ return;
+ end if;
+
-- Activation chain is never used for sequential elaboration policy, see
-- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
Ren_Decl : Node_Id;
begin
- -- Nothing to do if there is no task hierarchy
+ -- No action needed if the run-time has no tasking support
- if Restriction_Active (No_Task_Hierarchy) then
+ if Global_No_Tasking then
return;
end if;
then
begin
Set_Has_Master_Entity (Master_Scope);
-
- -- Generate:
- -- _master : constant Integer := Current_Master.all;
-
- Master_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Standard_Integer, Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
-
+ Master_Decl := Build_Master_Declaration (Loc);
Insert_Action (Find_Hook_Context (Related_Node), Master_Decl);
Analyze (Master_Decl);
return Ecount;
end Build_Entry_Count_Expression;
+ ------------------------------
+ -- Build_Master_Declaration --
+ ------------------------------
+
+ function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id is
+ Master_Decl : Node_Id;
+
+ begin
+ -- Generate a dummy master if tasks or tasking hierarchies are
+ -- prohibited.
+
+ -- _Master : constant Master_Id := 3;
+
+ if not Tasking_Allowed
+ or else Restrictions.Set (No_Task_Hierarchy)
+ or else not RTE_Available (RE_Current_Master)
+ then
+ declare
+ Expr : Node_Id;
+
+ begin
+ -- RE_Library_Task_Level is not always available in configurable
+ -- RunTime
+
+ if not RTE_Available (RE_Library_Task_Level) then
+ Expr := Make_Integer_Literal (Loc, Uint_3);
+ else
+ Expr := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc);
+ end if;
+
+ Master_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uMaster),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Integer, Loc),
+ Expression => Expr);
+ end;
+
+ -- Generate:
+ -- _master : constant Integer := Current_Master.all;
+
+ else
+ Master_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uMaster),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Integer, Loc),
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
+ end if;
+
+ return Master_Decl;
+ end Build_Master_Declaration;
+
---------------------------
-- Build_Parameter_Block --
---------------------------
Par : Node_Id;
begin
+ -- No action needed if the run-time has no tasking support
+
+ if Global_No_Tasking then
+ return;
+ end if;
+
if Is_Itype (Obj_Or_Typ) then
Par := Associated_Node_For_Itype (Obj_Or_Typ);
else
Par := Parent (Obj_Or_Typ);
end if;
+ -- For transient scopes check if the master entity is already defined
+
+ if Is_Type (Obj_Or_Typ)
+ and then Ekind (Scope (Obj_Or_Typ)) = E_Block
+ and then Is_Internal (Scope (Obj_Or_Typ))
+ then
+ declare
+ Master_Scope : constant Entity_Id :=
+ Find_Master_Scope (Obj_Or_Typ);
+ begin
+ if Has_Master_Entity (Master_Scope)
+ or else Is_Finalizer (Master_Scope)
+ then
+ return;
+ end if;
+
+ if Present (Current_Entity_In_Scope (Name_uMaster)) then
+ return;
+ end if;
+ end;
+ end if;
+
-- When creating a master for a record component which is either a task
-- or access-to-task, the enclosing record is the master scope and the
-- proper insertion point is the component list.
Find_Enclosing_Context (Par, Context, Context_Id, Decls);
end if;
- -- Nothing to do if the context already has a master
+ -- Nothing to do if the context already has a master; internally build
+ -- finalizers don't need a master.
- if Has_Master_Entity (Context_Id) then
- return;
-
- -- Nothing to do if tasks or tasking hierarchies are prohibited
-
- elsif Restriction_Active (No_Tasking)
- or else Restriction_Active (No_Task_Hierarchy)
+ if Has_Master_Entity (Context_Id)
+ or else Is_Finalizer (Context_Id)
then
return;
end if;
- -- Create a master, generate:
- -- _Master : constant Master_Id := Current_Master.all;
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
+ Decl := Build_Master_Declaration (Loc);
-- The master is inserted at the start of the declarative list of the
-- context.
Master_Id : Entity_Id;
begin
- -- Nothing to do if tasks or tasking hierarchies are prohibited
+ -- No action needed if the run-time has no tasking support
- if Restriction_Active (No_Tasking)
- or else Restriction_Active (No_Task_Hierarchy)
- then
+ if Global_No_Tasking then
return;
end if;
Chain := Activation_Chain_Entity (Owner);
-- Nothing to do when there are no tasks to activate. This is indicated
- -- by a missing activation chain entity.
+ -- by a missing activation chain entity; skip also generating it when
+ -- it is a ghost entity.
- if No (Chain) then
+ if No (Chain) or else Is_Ignored_Ghost_Entity (Chain) then
return;
end if;
if Ada_Version >= Ada_2005 then
while Is_Internal (S) loop
if Nkind (Parent (S)) = N_Block_Statement
- and then
- Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
+ and then Has_Master_Entity (S)
then
exit;
-- interface, ensure that the designated type has a _master and generate
-- a renaming of the said master to service the access type.
+ function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id;
+ -- For targets supporting tasks generate:
+ -- _Master : constant Integer := Current_Master.all;
+ -- For targets where tasks or tasking hierarchies are prohibited generate:
+ -- _Master : constant Master_Id := 3;
+
procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id);
-- Given the name of an object or a type which is either a task, contains
-- tasks or designates tasks, create a _master in the appropriate scope
package body Restrict is
+ Global_Restriction_No_Tasking : Boolean := False;
+ -- Set to True when No_Tasking is set in the run-time package System
+ -- or in a configuration pragmas file (for example, gnat.adc).
+
--------------------------------
-- Package Local Declarations --
--------------------------------
return Not_A_Restriction_Id;
end Get_Restriction_Id;
+ -----------------------
+ -- Global_No_Tasking --
+ -----------------------
+
+ function Global_No_Tasking return Boolean is
+ begin
+ return Global_Restriction_No_Tasking;
+ end Global_No_Tasking;
+
-------------------------------
-- No_Exception_Handlers_Set --
-------------------------------
No_Use_Of_Pragma_Warning (A_Id) := False;
end Set_Restriction_No_Use_Of_Pragma;
+ ---------------------------
+ -- Set_Global_No_Tasking --
+ ---------------------------
+
+ procedure Set_Global_No_Tasking is
+ begin
+ Global_Restriction_No_Tasking := True;
+ end Set_Global_No_Tasking;
+
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
-- of individual Restrictions pragmas). Returns True only if all the
-- required restrictions are set.
+ procedure Set_Global_No_Tasking;
+ -- Used in call from Sem_Prag when restriction No_Tasking is set in the
+ -- run-time package System or in a configuration pragmas file.
+
procedure Set_Profile_Restrictions
(P : Profile_Name;
N : Node_Id;
-- Tests if tasking operations are allowed by the current restrictions
-- settings. For tasking to be allowed Max_Tasks must be non-zero.
+ function Global_No_Tasking return Boolean;
+ -- Returns True if the restriction No_Tasking is set in the run-time
+ -- package System or in a configuration pragmas file.
+
----------------------------------------------
-- Handling of Boolean Compilation Switches --
----------------------------------------------
then
if Is_Limited_Record (Desig_Type)
and then Is_Class_Wide_Type (Desig_Type)
- and then Tasking_Allowed
then
Build_Class_Wide_Master (Anon_Type);
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Cloned_Subtype (Id, T);
Set_Is_Tagged_Type (Id, True);
+ Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Unknown_Discriminants
(Id, True);
Set_No_Tagged_Streams_Pragma
if Is_Interface (T) then
Set_Is_Interface (Id);
+ Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
end if;
if Present (Generic_Parent_Type (N))
-- Show Full is simply a renaming of Full_Base
Set_Cloned_Subtype (Full, Full_Base);
+ Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base));
-- Propagate predicates
if Is_Tagged_Type (Full_Base) then
Set_Is_Tagged_Type (Full);
+ Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base));
+
Set_Direct_Primitive_Operations
(Full, Direct_Primitive_Operations (Full_Base));
Set_No_Tagged_Streams_Pragma
(Full, No_Tagged_Streams_Pragma (Full_Base));
+ if Is_Interface (Full_Base) then
+ Set_Is_Interface (Full);
+ Set_Is_Limited_Interface (Full, Is_Limited_Interface (Full_Base));
+ end if;
+
-- Inherit class_wide type of full_base in case the partial view was
-- not tagged. Otherwise it has already been created when the private
-- subtype was analyzed.
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
-with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
and then
Is_Limited_Record (Designated_Type (Etype (Scop)))))
and then Expander_Active
-
- -- Avoid cases with no tasking support
-
- and then RTE_Available (RE_Current_Master)
- and then not Restriction_Active (No_Task_Hierarchy)
then
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Master_Id), Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
+ Decl := Build_Master_Declaration (Loc);
if Present (Declarations (N)) then
Prepend (Decl, Declarations (N));
Add_Extra_Formal
(E, RTE (RE_Master_Id),
E, BIP_Formal_Suffix (BIP_Task_Master));
+
+ Set_Has_Master_Entity (E);
+
Discard :=
Add_Extra_Formal
(E, RTE (RE_Activation_Chain_Access),
else
Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
end if;
+
+ -- Special processing for No_Tasking restriction
+
+ elsif R_Id = No_Tasking then
+
+ -- Handle global configuration pragmas
+
+ if No (Cunit (Main_Unit)) then
+ Set_Global_No_Tasking;
+
+ -- Handle package System, which may be loaded by rtsfind as
+ -- a consequence of loading some other run-time unit.
+
+ else
+ declare
+ C_Node : constant Entity_Id :=
+ Cunit (Current_Sem_Unit);
+ C_Ent : constant Entity_Id :=
+ Cunit_Entity (Current_Sem_Unit);
+ Loc_Str : constant String :=
+ Build_Location_String (Sloc (C_Ent));
+ Ref_Str : constant String := "system.ads";
+ Ref_Len : constant Positive := Ref_Str'Length;
+
+ begin
+ pragma Assert (Loc_Str'First = 1);
+ pragma Assert (Loc_Str'First = Ref_Str'First);
+
+ if Nkind (Unit (C_Node)) = N_Package_Declaration
+ and then Chars (C_Ent) = Name_System
+
+ -- Handle child packages named foo-system.ads
+
+ and then Loc_Str'Length > Ref_Str'Length
+ and then Loc_Str (Loc_Str'First .. Ref_Len)
+ = Ref_Str (Ref_Str'First .. Ref_Len)
+
+ -- ... and ensure that package System has not
+ -- been previously loaded. Done to ensure that
+ -- the above checks do not have any corner case
+ -- (since they are performed without semantic
+ -- information).
+
+ and then not RTU_Loaded (Rtsfind.System)
+ then
+ Set_Global_No_Tasking;
+ end if;
+ end;
+ end if;
end if;
-- If this is a warning, then set the warning unless we already
-- Current_Entity_In_Scope --
-----------------------------
- function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
+ function Current_Entity_In_Scope (N : Name_Id) return Entity_Id is
E : Entity_Id;
CS : constant Entity_Id := Current_Scope;
Transient_Case : constant Boolean := Scope_Is_Transient;
begin
- E := Get_Name_Entity_Id (Chars (N));
+ E := Get_Name_Entity_Id (N);
while Present (E)
and then Scope (E) /= CS
and then (not Transient_Case or else Scope (E) /= Scope (CS))
return E;
end Current_Entity_In_Scope;
+ -----------------------------
+ -- Current_Entity_In_Scope --
+ -----------------------------
+
+ function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
+ begin
+ return Current_Entity_In_Scope (Chars (N));
+ end Current_Entity_In_Scope;
+
-------------------
-- Current_Scope --
-------------------
-- Find the currently visible definition for a given identifier, that is to
-- say the first entry in the visibility chain for the Chars of N.
+ function Current_Entity_In_Scope (N : Name_Id) return Entity_Id;
function Current_Entity_In_Scope (N : Node_Id) return Entity_Id;
- -- Find whether there is a previous definition for identifier N in the
- -- current scope. Because declarations for a scope are not necessarily
+ -- Find whether there is a previous definition for name or identifier N in
+ -- the current scope. Because declarations for a scope are not necessarily
-- contiguous (e.g. for packages) the first entry on the visibility chain
-- for N is not necessarily in the current scope.
projects / gcc.git / commitdiff