public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc/devel/autopar_devel] [Ada] Crash in tagged type constructor with task components
@ 2020-08-22 22:46 Giuliano Belinassi
0 siblings, 0 replies; 7+ messages in thread
From: Giuliano Belinassi @ 2020-08-22 22:46 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:db81c4e87092492ecf1c1fcb997a2c0fdcdd2c2c
commit db81c4e87092492ecf1c1fcb997a2c0fdcdd2c2c
Author: Javier Miranda <miranda@adacore.com>
Date: Mon Apr 20 15:17:05 2020 -0400
[Ada] Crash in tagged type constructor with task components
2020-06-18 Javier Miranda <miranda@adacore.com>
gcc/ada/
* exp_disp.adb (Expand_Dispatching_Call): Add missing decoration
of attribute Extra_Accessibility_Of_Result.
* freeze.adb (Check_Extra_Formals): No check required if
expansion is disabled; Adding check on
Extra_Accessibilty_Of_Result.
(Freeze_Subprogram): Fix decoration of
Extra_Accessibility_Of_Result.
* sem_ch3.adb (Derive_Subprogram): Fix decoration of
Extra_Accessibility_Of_Result
Diff:
---
gcc/ada/exp_disp.adb | 14 ++++++++++++++
gcc/ada/freeze.adb | 27 +++++++++++++++++++++++----
gcc/ada/sem_ch3.adb | 5 +++++
3 files changed, 42 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 1585998df32..65d5b2a37aa 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1085,12 +1085,26 @@ package body Exp_Disp is
Set_Extra_Formal (Last_Formal, New_Formal);
Set_Extra_Formals (Subp_Typ, New_Formal);
+ if Ekind (Subp) = E_Function
+ and then Present (Extra_Accessibility_Of_Result (Subp))
+ and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
+ then
+ Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
+ end if;
+
Old_Formal := Extra_Formal (Old_Formal);
while Present (Old_Formal) loop
Set_Extra_Formal (New_Formal, New_Copy (Old_Formal));
New_Formal := Extra_Formal (New_Formal);
Set_Scope (New_Formal, Subp_Typ);
+ if Ekind (Subp) = E_Function
+ and then Present (Extra_Accessibility_Of_Result (Subp))
+ and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
+ then
+ Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
+ end if;
+
Old_Formal := Extra_Formal (Old_Formal);
end loop;
end if;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 4862c7df084..57b48941c37 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -8718,6 +8718,14 @@ package body Freeze is
Has_Extra_Formals : Boolean := False;
begin
+ -- No check required if expansion is disabled because extra
+ -- formals are only generated when we are generating code.
+ -- See Create_Extra_Formals.
+
+ if not Expander_Active then
+ return True;
+ end if;
+
-- Check attribute Extra_Formal: if available it must be set only
-- in the last formal of E
@@ -8735,6 +8743,15 @@ package body Freeze is
Next_Formal (Formal);
end loop;
+ -- Check attribute Extra_Accessibility_Of_Result
+
+ if Ekind_In (E, E_Function, E_Subprogram_Type)
+ and then Needs_Result_Accessibility_Level (E)
+ and then No (Extra_Accessibility_Of_Result (E))
+ then
+ return False;
+ end if;
+
-- Check attribute Extra_Formals: if E has extra formals then this
-- attribute must must point to the first extra formal of E.
@@ -8897,14 +8914,16 @@ package body Freeze is
-- still unset (and must be set now).
if Present (Alias (E))
+ and then Is_Frozen (Ultimate_Alias (E))
and then Present (Extra_Formals (Ultimate_Alias (E)))
and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
then
- pragma Assert (Is_Frozen (Ultimate_Alias (E)));
- pragma Assert (No (First_Formal (Ultimate_Alias (E)))
- or else
- Present (Extra_Formal (Last_Formal (Ultimate_Alias (E)))));
Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
+
+ if Ekind (E) = E_Function then
+ Set_Extra_Accessibility_Of_Result (E,
+ Extra_Accessibility_Of_Result (Ultimate_Alias (E)));
+ end if;
else
Create_Extra_Formals (E);
end if;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 6e0cfe2b8a8..78de3885a15 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -15563,6 +15563,11 @@ package body Sem_Ch3 is
Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
+ if Ekind (New_Subp) = E_Function then
+ Set_Extra_Accessibility_Of_Result (New_Subp,
+ Extra_Accessibility_Of_Result (Parent_Subp));
+ end if;
+
-- If this derivation corresponds to a tagged generic actual, then
-- primitive operations rename those of the actual. Otherwise the
-- primitive operations rename those of the parent type, If the parent
^ permalink raw reply [flat|nested] 7+ messages in thread
* [gcc/devel/autopar_devel] [Ada] Crash in tagged type constructor with task components
@ 2020-08-22 22:48 Giuliano Belinassi
0 siblings, 0 replies; 7+ messages in thread
From: Giuliano Belinassi @ 2020-08-22 22:48 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:38029ee563f016b2132f3a25fb5dea20b52b9159
commit 38029ee563f016b2132f3a25fb5dea20b52b9159
Author: Javier Miranda <miranda@adacore.com>
Date: Thu Apr 23 13:36:43 2020 -0400
[Ada] Crash in tagged type constructor with task components
2020-06-18 Javier Miranda <miranda@adacore.com>
gcc/ada/
* exp_ch6.adb (BIP_Suffix_Kind, Is_Build_In_Place_Entity): Move
declarations...
* exp_ch6.ads: Here.
* exp_util.adb (Is_Secondary_Stack_BIP_Func_Call): Do not rely
on the name of the scope to locate the extra formal BIPalloc
since they are copied when the pointer type associated with
dispatching calls is built; rely on routines
Is_Build_In_Place_Entity and BIP_Suffix_Kind.
* exp_disp.adb (Expand_Dispatching_Call): Set the scope of the
first extra formal of the internally built pointer type.
* sem_ch3.adb (Derive_Subprogram): Do not inherit extra formals
from a limited interface parent since limitedness is not
inherited in such case (AI-419) and this affects the extra
formals.
* sprint.adb (Write_Itype): Output extra formals of subprogram
types.
Diff:
---
gcc/ada/exp_ch6.adb | 6 ------
gcc/ada/exp_ch6.ads | 6 ++++++
gcc/ada/exp_disp.adb | 1 +
gcc/ada/exp_util.adb | 15 ++-------------
gcc/ada/sem_ch3.adb | 26 ++++++++++++++++++++------
gcc/ada/sprint.adb | 37 +++++++++++++++++++++++++++++++++++++
6 files changed, 66 insertions(+), 25 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 00a0aef0631..3562193afc7 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -156,9 +156,6 @@ package body Exp_Ch6 is
-- level is known not to be statically deeper than the result type of the
-- function.
- function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind;
- -- Ada 2005 (AI-318-02): Returns the kind of the given extra formal.
-
function Caller_Known_Size
(Func_Call : Node_Id;
Result_Subt : Entity_Id) return Boolean;
@@ -285,9 +282,6 @@ package body Exp_Ch6 is
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
- function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
- -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
-
procedure Replace_Renaming_Declaration_Id
(New_Decl : Node_Id;
Orig_Decl : Node_Id);
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 1c30219cbad..69b19090102 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -102,6 +102,9 @@ package Exp_Ch6 is
-- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
-- for build-in-place formal parameters of the given kind.
+ function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind;
+ -- Ada 2005 (AI-318-02): Returns the kind of the given BIP extra formal.
+
function Build_In_Place_Formal
(Func : Entity_Id;
Kind : BIP_Formal_Kind) return Entity_Id;
@@ -117,6 +120,9 @@ package Exp_Ch6 is
-- The returned node is the root of the procedure body which will replace
-- the original function body, which is not needed for the C program.
+ function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
+
function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if functions returning the type use
-- build-in-place protocols. For inherently limited types, this must be
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 65d5b2a37aa..89f206ed09f 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1081,6 +1081,7 @@ package body Exp_Disp is
then
Old_Formal := Extra_Formal (Last_Formal);
New_Formal := New_Copy (Old_Formal);
+ Set_Scope (New_Formal, Subp_Typ);
Set_Extra_Formal (Last_Formal, New_Formal);
Set_Extra_Formals (Subp_Typ, New_Formal);
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 537f0fc2490..d93788b8e5b 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8829,7 +8829,6 @@ package body Exp_Util is
--------------------------------------
function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
- Alloc_Nam : Name_Id := No_Name;
Actual : Node_Id;
Call : Node_Id := Expr;
Formal : Node_Id;
@@ -8856,20 +8855,10 @@ package body Exp_Util is
Formal := Selector_Name (Param);
Actual := Explicit_Actual_Parameter (Param);
- -- Construct the name of formal BIPalloc. It is much easier to
- -- extract the name of the function using an arbitrary formal's
- -- scope rather than the Name field of Call.
-
- if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
- Alloc_Nam :=
- New_External_Name
- (Chars (Scope (Entity (Formal))),
- BIP_Formal_Suffix (BIP_Alloc_Form));
- end if;
-
-- A match for BIPalloc => 2 has been found
- if Chars (Formal) = Alloc_Nam
+ if Is_Build_In_Place_Entity (Formal)
+ and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
and then Nkind (Actual) = N_Integer_Literal
and then Intval (Actual) = Uint_2
then
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 04060baa11e..8bb62c7a60a 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -15539,6 +15539,15 @@ package body Sem_Ch3 is
while Present (Formal) loop
New_Formal := New_Copy (Formal);
+ -- Extra formals are not inherited from a limited interface parent
+ -- since limitedness is not inherited in such case (AI-419) and this
+ -- affects the extra formals.
+
+ if Is_Limited_Interface (Parent_Type) then
+ Set_Extra_Formal (New_Formal, Empty);
+ Set_Extra_Accessibility (New_Formal, Empty);
+ end if;
+
-- Normally we do not go copying parents, but in the case of
-- formals, we need to link up to the declaration (which is the
-- parameter specification), and it is fine to link up to the
@@ -15558,14 +15567,19 @@ package body Sem_Ch3 is
end loop;
-- Extra formals are shared between the parent subprogram and the
- -- derived subprogram (implicit in the above copy of formals), and
- -- hence we must inherit also the reference to the first extra formal.
+ -- derived subprogram (implicit in the above copy of formals), unless
+ -- the parent type is a limited interface type; hence we must inherit
+ -- also the reference to the first extra formal. When the parent type is
+ -- an interface the extra formals will be added when the subprogram is
+ -- frozen (see Freeze.Freeze_Subprogram).
- Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
+ if not Is_Limited_Interface (Parent_Type) then
+ Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
- if Ekind (New_Subp) = E_Function then
- Set_Extra_Accessibility_Of_Result (New_Subp,
- Extra_Accessibility_Of_Result (Parent_Subp));
+ if Ekind (New_Subp) = E_Function then
+ Set_Extra_Accessibility_Of_Result (New_Subp,
+ Extra_Accessibility_Of_Result (Parent_Subp));
+ end if;
end if;
-- If this derivation corresponds to a tagged generic actual, then
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index f177981de70..7bfa5017019 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -4489,6 +4489,43 @@ package body Sprint is
Write_Str (", ");
end loop;
+ if Present (Extra_Formals (Typ)) then
+ Param := Extra_Formals (Typ);
+
+ while Present (Param) loop
+ Write_Str (", ");
+ Write_Id (Param);
+ Write_Str (" : ");
+ Write_Id (Etype (Param));
+
+ Param := Extra_Formal (Param);
+ end loop;
+ end if;
+
+ Write_Char (')');
+ end;
+
+ elsif Present (Extra_Formals (Typ)) then
+ declare
+ Param : Entity_Id;
+
+ begin
+ Write_Str (" (");
+
+ Param := Extra_Formals (Typ);
+
+ while Present (Param) loop
+ Write_Id (Param);
+ Write_Str (" : ");
+ Write_Id (Etype (Param));
+
+ if Present (Extra_Formal (Param)) then
+ Write_Str (", ");
+ end if;
+
+ Param := Extra_Formal (Param);
+ end loop;
+
Write_Char (')');
end;
end if;
^ permalink raw reply [flat|nested] 7+ messages in thread
* [gcc/devel/autopar_devel] [Ada] Crash in tagged type constructor with task components
@ 2020-08-22 22:43 Giuliano Belinassi
0 siblings, 0 replies; 7+ messages in thread
From: Giuliano Belinassi @ 2020-08-22 22:43 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:b9e722e173a5231b2a339bff07fca3db4fb5ad05
commit b9e722e173a5231b2a339bff07fca3db4fb5ad05
Author: Javier Miranda <miranda@adacore.com>
Date: Thu Apr 16 11:06:31 2020 -0400
[Ada] Crash in tagged type constructor with task components
2020-06-17 Javier Miranda <miranda@adacore.com>
gcc/ada/
* exp_ch6.adb (Has_BIP_Extra_Formal): New subprogram.
(Needs_BIP_Task_Actuals): Add support for the subprogram type
internally generated for dispatching calls.
* exp_disp.adb (Expand_Dispatching_Call): Adding code to
explicitly duplicate the extra formals of the target subprogram.
* freeze.adb (Check_Extra_Formals): New subprogram.
(Freeze_Subprogram): Fix decoration of Extra_Formals.
* sem_ch3.adb (Derive_Subprogram): Fix decoration of
Extra_Formals.
Diff:
---
gcc/ada/exp_ch6.adb | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++--
gcc/ada/exp_disp.adb | 44 ++++++++++++++++++++++-------
gcc/ada/freeze.adb | 70 ++++++++++++++++++++++++++++++++++++++++++++-
gcc/ada/sem_ch3.adb | 6 ++++
4 files changed, 186 insertions(+), 14 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 2d065aa8e14..daa672f0193 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -272,6 +272,15 @@ package body Exp_Ch6 is
-- Expand simple return from function. In the case where we are returning
-- from a function body this is called by Expand_N_Simple_Return_Statement.
+ function Has_BIP_Extra_Formal
+ (E : Entity_Id;
+ Kind : BIP_Formal_Kind) return Boolean;
+ -- Given a frozen subprogram, subprogram type, entry or entry family,
+ -- return True if E has the BIP extra formal associated with Kind. It must
+ -- be invoked with a frozen entity or a subprogram type of a dispatching
+ -- call since we can only rely on the availability of the extra formals
+ -- on these entities.
+
procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
@@ -828,8 +837,8 @@ package body Exp_Ch6 is
(Func : Entity_Id;
Kind : BIP_Formal_Kind) return Entity_Id
is
+ Extra_Formal : Entity_Id := Extra_Formals (Func);
Formal_Suffix : constant String := BIP_Formal_Suffix (Kind);
- Extra_Formal : Entity_Id := Extra_Formals (Func);
begin
-- Maybe it would be better for each implicit formal of a build-in-place
@@ -8230,6 +8239,41 @@ package body Exp_Ch6 is
end if;
end Freeze_Subprogram;
+ --------------------------
+ -- Has_BIP_Extra_Formal --
+ --------------------------
+
+ function Has_BIP_Extra_Formal
+ (E : Entity_Id;
+ Kind : BIP_Formal_Kind) return Boolean
+ is
+ Extra_Formal : Entity_Id := Extra_Formals (E);
+
+ begin
+ -- We can only rely on the availability of the extra formals in frozen
+ -- entities or in subprogram types of dispatching calls (since their
+ -- extra formals are added when the target subprogram is frozen; see
+ -- Expand_Dispatching_Call).
+
+ pragma Assert (Is_Frozen (E)
+ or else (Ekind (E) = E_Subprogram_Type
+ and then Is_Dispatch_Table_Entity (E))
+ or else (Is_Dispatching_Operation (E)
+ and then Is_Frozen (Find_Dispatching_Type (E))));
+
+ while Present (Extra_Formal) loop
+ if Is_Build_In_Place_Entity (Extra_Formal)
+ and then BIP_Suffix_Kind (Extra_Formal) = Kind
+ then
+ return True;
+ end if;
+
+ Next_Formal_With_Extras (Extra_Formal);
+ end loop;
+
+ return False;
+ end Has_BIP_Extra_Formal;
+
------------------------------
-- Insert_Post_Call_Actions --
------------------------------
@@ -9871,6 +9915,10 @@ package body Exp_Ch6 is
Func_Typ : Entity_Id;
begin
+ if Global_No_Tasking or else No_Run_Time_Mode then
+ return False;
+ end if;
+
-- For thunks we must rely on their target entity; otherwise, given that
-- the profile of thunks for functions returning a limited interface
-- type returns a class-wide type, we would erroneously add these extra
@@ -9887,8 +9935,34 @@ package body Exp_Ch6 is
Func_Typ := Underlying_Type (Etype (Subp_Id));
- return not Global_No_Tasking
- and then (Has_Task (Func_Typ) or else Might_Have_Tasks (Func_Typ));
+ -- At first sight, for all the following cases, we could add assertions
+ -- to ensure that if Func_Id is frozen then the computed result matches
+ -- with the availability of the task master extra formal; unfortunately
+ -- this is not feasible because we may be precisely freezing this entity
+ -- (ie. Is_Frozen has been set by Freeze_Entity but it has not completed
+ -- its work).
+
+ if Has_Task (Func_Typ) then
+ return True;
+
+ elsif Ekind (Func_Id) = E_Function then
+ return Might_Have_Tasks (Func_Typ);
+
+ -- Handle subprogram type internally generated for dispatching call. We
+ -- can not rely on the return type of the subprogram type of dispatching
+ -- calls since it is always a class-wide type (cf. Expand_Dispatching_
+ -- _Call).
+
+ elsif Ekind (Func_Id) = E_Subprogram_Type then
+ if Is_Dispatch_Table_Entity (Func_Id) then
+ return Has_BIP_Extra_Formal (Func_Id, BIP_Task_Master);
+ else
+ return Might_Have_Tasks (Func_Typ);
+ end if;
+
+ else
+ raise Program_Error;
+ end if;
end Needs_BIP_Task_Actuals;
-----------------------------------
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index b57ba586062..1585998df32 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1023,9 +1023,9 @@ package body Exp_Disp is
-- list including the creation of a new set of matching entities.
declare
- Old_Formal : Entity_Id := First_Formal (Subp);
- New_Formal : Entity_Id;
- Extra : Entity_Id := Empty;
+ Old_Formal : Entity_Id := First_Formal (Subp);
+ New_Formal : Entity_Id;
+ Last_Formal : Entity_Id := Empty;
begin
if Present (Old_Formal) then
@@ -1049,7 +1049,7 @@ package body Exp_Disp is
-- errors when the itype is the completion of a type derived
-- from a private type.
- Extra := New_Formal;
+ Last_Formal := New_Formal;
Next_Formal (Old_Formal);
exit when No (Old_Formal);
@@ -1059,17 +1059,41 @@ package body Exp_Disp is
end loop;
Unlink_Next_Entity (New_Formal);
- Set_Last_Entity (Subp_Typ, Extra);
+ Set_Last_Entity (Subp_Typ, Last_Formal);
end if;
-- Now that the explicit formals have been duplicated, any extra
- -- formals needed by the subprogram must be created.
+ -- formals needed by the subprogram must be duplicated; we know
+ -- that extra formals are available because they were added when
+ -- the tagged type was frozen (see Expand_Freeze_Record_Type).
- if Present (Extra) then
- Set_Extra_Formal (Extra, Empty);
- end if;
+ pragma Assert (Is_Frozen (Typ));
+
+ -- Warning: The addition of the extra formals cannot be performed
+ -- here invoking Create_Extra_Formals since we must ensure that all
+ -- the extra formals of the pointer type and the target subprogram
+ -- match (and for functions that return a tagged type the profile of
+ -- the built subprogram type always returns a class-wide type, which
+ -- may affect the addition of some extra formals).
+
+ if Present (Last_Formal)
+ and then Present (Extra_Formal (Last_Formal))
+ then
+ Old_Formal := Extra_Formal (Last_Formal);
+ New_Formal := New_Copy (Old_Formal);
- Create_Extra_Formals (Subp_Typ);
+ Set_Extra_Formal (Last_Formal, New_Formal);
+ Set_Extra_Formals (Subp_Typ, New_Formal);
+
+ Old_Formal := Extra_Formal (Old_Formal);
+ while Present (Old_Formal) loop
+ Set_Extra_Formal (New_Formal, New_Copy (Old_Formal));
+ New_Formal := Extra_Formal (New_Formal);
+ Set_Scope (New_Formal, Subp_Typ);
+
+ Old_Formal := Extra_Formal (Old_Formal);
+ end loop;
+ end if;
end;
-- Complete description of pointer type, including size information, as
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 0f6739f97bc..4862c7df084 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -8700,10 +8700,60 @@ package body Freeze is
-----------------------
procedure Freeze_Subprogram (E : Entity_Id) is
+ function Check_Extra_Formals (E : Entity_Id) return Boolean;
+ -- Return True if the decoration of the attributes associated with extra
+ -- formals are properly set.
+
procedure Set_Profile_Convention (Subp_Id : Entity_Id);
-- Set the conventions of all anonymous access-to-subprogram formals and
-- result subtype of subprogram Subp_Id to the convention of Subp_Id.
+ -------------------------
+ -- Check_Extra_Formals --
+ -------------------------
+
+ function Check_Extra_Formals (E : Entity_Id) return Boolean is
+ Last_Formal : Entity_Id := Empty;
+ Formal : Entity_Id;
+ Has_Extra_Formals : Boolean := False;
+
+ begin
+ -- Check attribute Extra_Formal: if available it must be set only
+ -- in the last formal of E
+
+ Formal := First_Formal (E);
+ while Present (Formal) loop
+ if Present (Extra_Formal (Formal)) then
+ if Has_Extra_Formals then
+ return False;
+ end if;
+
+ Has_Extra_Formals := True;
+ end if;
+
+ Last_Formal := Formal;
+ Next_Formal (Formal);
+ end loop;
+
+ -- Check attribute Extra_Formals: if E has extra formals then this
+ -- attribute must must point to the first extra formal of E.
+
+ if Has_Extra_Formals then
+ return Present (Extra_Formals (E))
+ and then Present (Extra_Formal (Last_Formal))
+ and then Extra_Formal (Last_Formal) = Extra_Formals (E);
+
+ -- When E has no formals the first extra formal is available through
+ -- the Extra_Formals attribute.
+
+ elsif Present (Extra_Formals (E)) then
+ return No (First_Formal (E));
+
+ else
+ return True;
+ end if;
+ end Check_Extra_Formals;
+
----------------------------
-- Set_Profile_Convention --
----------------------------
@@ -8840,9 +8890,27 @@ package body Freeze is
if not Has_Foreign_Convention (E) then
if No (Extra_Formals (E)) then
- Create_Extra_Formals (E);
+
+ -- Extra formals are shared by derived subprograms; therefore if
+ -- the ultimate alias of E has been frozen before E then the extra
+ -- formals have been added but the attribute Extra_Formals is
+ -- still unset (and must be set now).
+
+ if Present (Alias (E))
+ and then Present (Extra_Formals (Ultimate_Alias (E)))
+ and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
+ then
+ pragma Assert (Is_Frozen (Ultimate_Alias (E)));
+ pragma Assert (No (First_Formal (Ultimate_Alias (E)))
+ or else
+ Present (Extra_Formal (Last_Formal (Ultimate_Alias (E)))));
+ Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
+ else
+ Create_Extra_Formals (E);
+ end if;
end if;
+ pragma Assert (Check_Extra_Formals (E));
Set_Mechanisms (E);
-- If this is convention Ada and a Valued_Procedure, that's odd
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 63d0c6ddd39..4c3212d3dee 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -15557,6 +15557,12 @@ package body Sem_Ch3 is
Next_Formal (Formal);
end loop;
+ -- Extra formals are shared between the parent subprogram and the
+ -- derived subprogram (implicit in the above copy of formals), and
+ -- hence we must inherit also the reference to the first extra formal.
+
+ Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
+
-- If this derivation corresponds to a tagged generic actual, then
-- primitive operations rename those of the actual. Otherwise the
-- primitive operations rename those of the parent type, If the parent
^ permalink raw reply [flat|nested] 7+ messages in thread
* [gcc/devel/autopar_devel] [Ada] Crash in tagged type constructor with task components
@ 2020-08-22 22:38 Giuliano Belinassi
0 siblings, 0 replies; 7+ messages in thread
From: Giuliano Belinassi @ 2020-08-22 22:38 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:76432a9df8098de47108eab73f1114bd4236fa7d
commit 76432a9df8098de47108eab73f1114bd4236fa7d
Author: Javier Miranda <miranda@adacore.com>
Date: Wed Apr 8 09:43:58 2020 -0400
[Ada] Crash in tagged type constructor with task components
2020-06-16 Javier Miranda <miranda@adacore.com>
gcc/ada/
* exp_ch6.adb (BIP_Suffix_Kind, Check_BIP_Actuals,
Is_Build_In_Place_Entity): New subprograms.
(Make_Build_In_Place_Call_In_Allocator,
Make_Build_In_Place_Call_In_Anonymous_Context,
Make_Build_In_Place_Call_In_Assignment,
Make_Build_In_Place_Call_In_Object_Declaration): Add assertions.
(Needs_BIP_Task_Actuals): Add missing support for thunks.
(Expand_Actuals): Ensure that the BIP call has available an
activation chain and the _master variable.
* exp_ch9.adb (Find_Enclosing_Context): Initialize the list of
declarations of empty blocks when the _master variable must be
declared and the list was not available.
Diff:
---
gcc/ada/exp_ch6.adb | 176 +++++++++++++++++++++++++++++++++++++++++++++++++---
gcc/ada/exp_ch9.adb | 4 ++
2 files changed, 172 insertions(+), 8 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index d679a8a9c83..6ca5fd612b9 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -78,6 +78,15 @@ with Validsw; use Validsw;
package body Exp_Ch6 is
+ -- Suffix for BIP formals
+
+ BIP_Alloc_Suffix : constant String := "BIPalloc";
+ BIP_Storage_Pool_Suffix : constant String := "BIPstoragepool";
+ BIP_Finalization_Master_Suffix : constant String := "BIPfinalizationmaster";
+ BIP_Task_Master_Suffix : constant String := "BIPtaskmaster";
+ BIP_Activation_Chain_Suffix : constant String := "BIPactivationchain";
+ BIP_Object_Access_Suffix : constant String := "BIPaccess";
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -147,6 +156,9 @@ package body Exp_Ch6 is
-- level is known not to be statically deeper than the result type of the
-- function.
+ function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind;
+ -- Ada 2005 (AI-318-02): Returns the kind of the given extra formal.
+
function Caller_Known_Size
(Func_Call : Node_Id;
Result_Subt : Entity_Id) return Boolean;
@@ -156,6 +168,12 @@ package body Exp_Ch6 is
-- access discriminants do not require secondary stack use. Note we must
-- always use the secondary stack for dispatching-on-result calls.
+ function Check_BIP_Actuals
+ (Subp_Call : Node_Id;
+ Subp_Id : Entity_Id) return Boolean;
+ -- Given a subprogram call to the given subprogram return True if the
+ -- names of BIP extra actual and formal parameters match.
+
function Check_Number_Of_Actuals
(Subp_Call : Node_Id;
Subp_Id : Entity_Id) return Boolean;
@@ -258,6 +276,9 @@ package body Exp_Ch6 is
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
+ function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
+
procedure Replace_Renaming_Declaration_Id
(New_Decl : Node_Id;
Orig_Decl : Node_Id);
@@ -737,25 +758,68 @@ package body Exp_Ch6 is
begin
case Kind is
when BIP_Alloc_Form =>
- return "BIPalloc";
+ return BIP_Alloc_Suffix;
when BIP_Storage_Pool =>
- return "BIPstoragepool";
+ return BIP_Storage_Pool_Suffix;
when BIP_Finalization_Master =>
- return "BIPfinalizationmaster";
+ return BIP_Finalization_Master_Suffix;
when BIP_Task_Master =>
- return "BIPtaskmaster";
+ return BIP_Task_Master_Suffix;
when BIP_Activation_Chain =>
- return "BIPactivationchain";
+ return BIP_Activation_Chain_Suffix;
when BIP_Object_Access =>
- return "BIPaccess";
+ return BIP_Object_Access_Suffix;
end case;
end BIP_Formal_Suffix;
+ ---------------------
+ -- BIP_Suffix_Kind --
+ ---------------------
+
+ function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind is
+ Nam : constant String := Get_Name_String (Chars (E));
+
+ function Has_Suffix (Suffix : String) return Boolean;
+ -- Return True if Nam has suffix Suffix
+
+ function Has_Suffix (Suffix : String) return Boolean is
+ Len : constant Natural := Suffix'Length;
+ begin
+ return Nam'Length > Len
+ and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
+ end Has_Suffix;
+
+ -- Start of processing for BIP_Suffix_Kind
+
+ begin
+ if Has_Suffix (BIP_Alloc_Suffix) then
+ return BIP_Alloc_Form;
+
+ elsif Has_Suffix (BIP_Storage_Pool_Suffix) then
+ return BIP_Storage_Pool;
+
+ elsif Has_Suffix (BIP_Finalization_Master_Suffix) then
+ return BIP_Finalization_Master;
+
+ elsif Has_Suffix (BIP_Task_Master_Suffix) then
+ return BIP_Task_Master;
+
+ elsif Has_Suffix (BIP_Activation_Chain_Suffix) then
+ return BIP_Activation_Chain;
+
+ elsif Has_Suffix (BIP_Object_Access_Suffix) then
+ return BIP_Object_Access;
+
+ else
+ raise Program_Error;
+ end if;
+ end BIP_Suffix_Kind;
+
---------------------------
-- Build_In_Place_Formal --
---------------------------
@@ -987,6 +1051,42 @@ package body Exp_Ch6 is
or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
end Caller_Known_Size;
+ -----------------------
+ -- Check_BIP_Actuals --
+ -----------------------
+
+ function Check_BIP_Actuals
+ (Subp_Call : Node_Id;
+ Subp_Id : Entity_Id) return Boolean
+ is
+ Formal : Entity_Id;
+ Actual : Node_Id;
+
+ begin
+ pragma Assert (Nkind_In (Subp_Call, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement));
+
+ Formal := First_Formal_With_Extras (Subp_Id);
+ Actual := First_Actual (Subp_Call);
+
+ while Present (Formal) and then Present (Actual) loop
+ if Is_Build_In_Place_Entity (Formal)
+ and then Nkind (Actual) = N_Identifier
+ and then Is_Build_In_Place_Entity (Entity (Actual))
+ and then BIP_Suffix_Kind (Formal)
+ /= BIP_Suffix_Kind (Entity (Actual))
+ then
+ return False;
+ end if;
+
+ Next_Formal_With_Extras (Formal);
+ Next_Actual (Actual);
+ end loop;
+
+ return No (Formal) and then No (Actual);
+ end Check_BIP_Actuals;
+
-----------------------------
-- Check_Number_Of_Actuals --
-----------------------------
@@ -2160,13 +2260,18 @@ package body Exp_Ch6 is
-- Ada 2005 (AI-318-02): If the actual parameter is a call to a
-- build-in-place function, then a temporary return object needs
- -- to be created and access to it must be passed to the function.
+ -- to be created and access to it must be passed to the function
+ -- (and ensure that we have an activation chain defined for tasks
+ -- and a Master variable).
+
-- Currently we limit such functions to those with inherently
-- limited result subtypes, but eventually we plan to expand the
-- functions that are treated as build-in-place to include other
-- composite result types.
if Is_Build_In_Place_Function_Call (Actual) then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Etype (Actual));
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
-- Ada 2005 (AI-318-02): Specialization of the previous case for
@@ -2174,6 +2279,8 @@ package body Exp_Ch6 is
-- object covers interface types.
elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Etype (Actual));
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
end if;
@@ -3359,6 +3466,8 @@ package body Exp_Ch6 is
Expand_Actuals (Call_Node, Subp, Post_Call);
pragma Assert (Is_Empty_List (Post_Call));
+ pragma Assert (Check_Number_Of_Actuals (Call_Node, Subp));
+ pragma Assert (Check_BIP_Actuals (Call_Node, Subp));
return;
end;
end if;
@@ -8291,6 +8400,34 @@ package body Exp_Ch6 is
end if;
end Is_Build_In_Place_Result_Type;
+ ------------------------------
+ -- Is_Build_In_Place_Entity --
+ ------------------------------
+
+ function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean is
+ Nam : constant String := Get_Name_String (Chars (E));
+
+ function Has_Suffix (Suffix : String) return Boolean;
+ -- Return True if Nam has suffix Suffix
+
+ function Has_Suffix (Suffix : String) return Boolean is
+ Len : constant Natural := Suffix'Length;
+ begin
+ return Nam'Length > Len
+ and then Nam (Nam'Last - Len + 1 .. Nam'Last) = Suffix;
+ end Has_Suffix;
+
+ -- Start of processing for Is_Build_In_Place_Entity
+
+ begin
+ return Has_Suffix (BIP_Alloc_Suffix)
+ or else Has_Suffix (BIP_Storage_Pool_Suffix)
+ or else Has_Suffix (BIP_Finalization_Master_Suffix)
+ or else Has_Suffix (BIP_Task_Master_Suffix)
+ or else Has_Suffix (BIP_Activation_Chain_Suffix)
+ or else Has_Suffix (BIP_Object_Access_Suffix);
+ end Is_Build_In_Place_Entity;
+
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
@@ -8699,6 +8836,7 @@ package body Exp_Ch6 is
Analyze_And_Resolve (Allocator, Acc_Type);
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end Make_Build_In_Place_Call_In_Allocator;
---------------------------------------------------
@@ -8821,6 +8959,7 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
-- When the result subtype is unconstrained, the function must allocate
-- the return object in the secondary stack, so appropriate implicit
@@ -8847,6 +8986,7 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, Empty);
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end if;
end Make_Build_In_Place_Call_In_Anonymous_Context;
@@ -8953,6 +9093,7 @@ package body Exp_Ch6 is
Rewrite (Assign, Make_Null_Statement (Loc));
pragma Assert (Check_Number_Of_Actuals (Func_Call, Func_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Func_Id));
end Make_Build_In_Place_Call_In_Assignment;
----------------------------------------------------
@@ -9396,6 +9537,7 @@ package body Exp_Ch6 is
end if;
pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id));
+ pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id));
end Make_Build_In_Place_Call_In_Object_Declaration;
-------------------------------------------------
@@ -9686,8 +9828,26 @@ package body Exp_Ch6 is
function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
- Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+ Subp_Id : Entity_Id;
+ Func_Typ : Entity_Id;
+
begin
+ -- For thunks we must rely on their target entity; otherwise, given that
+ -- the profile of thunks for functions returning a limited interface
+ -- type returns a class-wide type, we would erroneously add these extra
+ -- formals.
+
+ if Is_Thunk (Func_Id) then
+ Subp_Id := Thunk_Entity (Func_Id);
+
+ -- Common case
+
+ else
+ Subp_Id := Func_Id;
+ end if;
+
+ Func_Typ := Underlying_Type (Etype (Subp_Id));
+
return not Global_No_Tasking
and then (Has_Task (Func_Typ) or else Might_Have_Tasks (Func_Typ));
end Needs_BIP_Task_Actuals;
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index adbaa7baad1..f4dc5d39046 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -13327,6 +13327,10 @@ package body Exp_Ch9 is
if Nkind (Context) = N_Block_Statement then
Context_Id := Entity (Identifier (Context));
+ if No (Declarations (Context)) then
+ Set_Declarations (Context, New_List);
+ end if;
+
elsif Nkind (Context) = N_Entry_Body then
Context_Id := Defining_Identifier (Context);
^ permalink raw reply [flat|nested] 7+ messages in thread
* [gcc/devel/autopar_devel] [Ada] Crash in tagged type constructor with task components
@ 2020-08-22 22:37 Giuliano Belinassi
0 siblings, 0 replies; 7+ messages in thread
From: Giuliano Belinassi @ 2020-08-22 22:37 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:70d4908d56cc85c1e0a6a26177e7cf2d971806c2
commit 70d4908d56cc85c1e0a6a26177e7cf2d971806c2
Author: Javier Miranda <miranda@adacore.com>
Date: Sat Apr 4 14:21:40 2020 -0400
[Ada] Crash in tagged type constructor with task components
2020-06-16 Javier Miranda <miranda@adacore.com>
gcc/ada/
* sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
Code cleanup.
Diff:
---
gcc/ada/sem_prag.adb | 51 ++++-----------------------------------------------
1 file changed, 4 insertions(+), 47 deletions(-)
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 673954acb5b..f3f0affb0ca 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10694,54 +10694,11 @@ package body Sem_Prag is
Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
end if;
- -- Special processing for No_Tasking restriction
+ -- Special processing for No_Tasking restriction placed in
+ -- a configuration pragmas file.
- 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;
+ elsif R_Id = No_Tasking and then No (Cunit (Main_Unit)) then
+ Set_Global_No_Tasking;
end if;
-- If this is a warning, then set the warning unless we already
^ permalink raw reply [flat|nested] 7+ messages in thread
* [gcc/devel/autopar_devel] [Ada] Crash in tagged type constructor with task components
@ 2020-08-22 22:37 Giuliano Belinassi
0 siblings, 0 replies; 7+ messages in thread
From: Giuliano Belinassi @ 2020-08-22 22:37 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:77f4b4574c72370c6f35cd6884b0e29b75ac4e1a
commit 77f4b4574c72370c6f35cd6884b0e29b75ac4e1a
Author: Javier Miranda <miranda@adacore.com>
Date: Fri Apr 3 17:29:48 2020 -0400
[Ada] Crash in tagged type constructor with task components
2020-06-16 Javier Miranda <miranda@adacore.com>
gcc/ada/
* restrict.adb (Global_No_Tasking): Adding
Targparm.Restrictions_On_Target Fixes regressions with zfp.
Diff:
---
gcc/ada/restrict.adb | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index ebdc7ce1c23..0dab4c5879d 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -35,6 +35,7 @@ with Opt; use Opt;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stand; use Stand;
+with Targparm; use Targparm;
with Uname; use Uname;
package body Restrict is
@@ -908,7 +909,8 @@ package body Restrict is
function Global_No_Tasking return Boolean is
begin
- return Global_Restriction_No_Tasking;
+ return Global_Restriction_No_Tasking
+ or else Targparm.Restrictions_On_Target.Set (No_Tasking);
end Global_No_Tasking;
-------------------------------
^ permalink raw reply [flat|nested] 7+ messages in thread
* [gcc/devel/autopar_devel] [Ada] Crash in tagged type constructor with task components
@ 2020-08-22 22:34 Giuliano Belinassi
0 siblings, 0 replies; 7+ messages in thread
From: Giuliano Belinassi @ 2020-08-22 22:34 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:d86d611501b20ef74db2363734653dbb79ae38bd
commit d86d611501b20ef74db2363734653dbb79ae38bd
Author: Javier Miranda <miranda@adacore.com>
Date: Sat Mar 28 14:52:14 2020 -0400
[Ada] Crash in tagged type constructor with task components
2020-06-15 Javier Miranda <miranda@adacore.com>
gcc/ada/
* restrict.ads (Set_Global_No_Tasking, Global_No_Tasking): New
subprograms.
* restrict.adb (Set_Global_No_Tasking, Global_No_Tasking): New
subprograms.
* sem_ch3.adb (Access_Definition): Do not skip building masters
since they may be required for BIP calls.
(Analyze_Subtype_Declaration): Propagate attribute
Is_Limited_Record in class-wide subtypes and subtypes with
cloned subtype attribute; propagate attribute
Is_Limited_Interface.
* sem_ch6.adb (Check_Anonymous_Return): Do not skip building
masters since they may be required for BIP calls. Use
Build_Master_Declaration to declare the _master variable.
(Create_Extra_Formals): Add decoration of Has_Master_Entity when
the _master formal is added.
* exp_ch3.adb (Init_Formals): Adding formal to decorate it with
attribute Has_Master_Entity when the _master formal is added.
(Build_Master): Do not skip building masters since they may be
required for BIP calls.
(Expand_N_Object_Declaration): Ensure activation chain and
master entity for objects initialized with BIP function calls.
* sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
Adding support to detect and save restriction No_Tasking when
set in the run-time package System or in a global configuration
pragmas file.
* sem_util.adb (Current_Entity_In_Scope): Overload this
subprogram to allow searching for an entity by its Name.
* sem_util.ads (Current_Entity_In_Scope): Update comment.
* exp_ch4.adb (Expand_N_Allocator): Do not skip building masters
since they may be required for BIP calls.
* exp_ch6.ads (Might_Have_Tasks): New subprogram.
* exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Add
support for BIP calls returning objects that may have tasks.
(Make_Build_In_Place_Call_In_Allocator): Build the activation
chain if the result might have tasks.
(Make_Build_In_Place_Iface_Call_In_Allocator): Build the class
wide master for the result type.
(Might_Have_Tasks): New subprogram.
(Needs_BIP_Task_Actuals): Returns False when restriction
No_Tasking is globally set.
* exp_ch9.ads (Build_Master_Declaration): New subprogram.
* exp_ch9.adb (Build_Activation_Chain_Entity): No action
performed when restriction No_Tasking is globally set.
(Build_Class_Wide_Master): No action performed when restriction
No_Tasking is globally set; use Build_Master_Declaration to
declare the _master variable.
(Build_Master_Declaration): New subprogram.
(Build_Master_Entity): No action performed when restriction
No_Tasking is globally set; added support to handle transient
scopes and _finalizer routines.
(Build_Master_Renaming): No action performed when restriction
No_Tasking is globally set.
(Build_Task_Activation_Call): Skip generating the call when
the chain is an ignored ghost entity.
(Find_Master_Scope): Generalize the code that detects transient
scopes with master entity.
* einfo.ads (Has_Nested_Subprogram): Minor comment reformatting.
Diff:
---
gcc/ada/einfo.ads | 4 +-
gcc/ada/exp_ch3.adb | 65 ++++++++++++++++------
gcc/ada/exp_ch4.adb | 22 ++++----
gcc/ada/exp_ch6.adb | 18 +++++-
gcc/ada/exp_ch6.ads | 4 ++
gcc/ada/exp_ch9.adb | 152 ++++++++++++++++++++++++++++++++++++---------------
gcc/ada/exp_ch9.ads | 6 ++
gcc/ada/restrict.adb | 22 ++++++++
gcc/ada/restrict.ads | 8 +++
gcc/ada/sem_ch3.adb | 11 +++-
gcc/ada/sem_ch6.adb | 20 ++-----
gcc/ada/sem_prag.adb | 49 +++++++++++++++++
gcc/ada/sem_util.adb | 13 ++++-
gcc/ada/sem_util.ads | 5 +-
14 files changed, 299 insertions(+), 100 deletions(-)
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 346a15eac5b..35efe5919f0 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1813,8 +1813,8 @@ package Einfo is
-- 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,
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 7d13cd6cd2b..b207a1f1c92 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -184,11 +184,11 @@ package body Exp_Ch3 is
-- 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
@@ -730,7 +730,7 @@ package body Exp_Ch3 is
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,
@@ -2438,7 +2438,7 @@ package body Exp_Ch3 is
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));
@@ -5720,7 +5720,7 @@ package body Exp_Ch3 is
-- 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);
@@ -5734,12 +5734,11 @@ package body Exp_Ch3 is
-- 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;
@@ -6666,14 +6665,39 @@ package body Exp_Ch3 is
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
@@ -6691,7 +6715,7 @@ package body Exp_Ch3 is
-- 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))
@@ -8862,7 +8886,8 @@ package body Exp_Ch3 is
-- 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);
@@ -8871,9 +8896,11 @@ package body Exp_Ch3 is
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
@@ -8902,6 +8929,8 @@ package body Exp_Ch3 is
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).
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index bf882251732..27410ffe934 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -5031,20 +5031,18 @@ package body Exp_Ch4 is
-- 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;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index b2b81eee9a1..1dd4493c785 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -8616,7 +8616,7 @@ package body Exp_Ch6 is
-- 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));
@@ -9393,6 +9393,7 @@ package body Exp_Ch6 is
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,
@@ -9627,6 +9628,18 @@ package body Exp_Ch6 is
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 --
----------------------------
@@ -9635,7 +9648,8 @@ package body Exp_Ch6 is
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;
-----------------------------------
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index b3dae148a55..1c30219cbad 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -234,6 +234,10 @@ package Exp_Ch6 is
-- 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).
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 5162118e46c..da6e3095b27 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -928,6 +928,12 @@ package body Exp_Ch9 is
-- 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).
@@ -1127,9 +1133,9 @@ package body Exp_Ch9 is
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;
@@ -1168,21 +1174,7 @@ package body Exp_Ch9 is
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);
@@ -1695,6 +1687,65 @@ package body Exp_Ch9 is
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 --
---------------------------
@@ -3345,12 +3396,40 @@ package body Exp_Ch9 is
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.
@@ -3368,31 +3447,16 @@ package body Exp_Ch9 is
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.
@@ -3448,11 +3512,9 @@ package body Exp_Ch9 is
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;
@@ -4794,9 +4856,10 @@ package body Exp_Ch9 is
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;
@@ -13312,8 +13375,7 @@ package body Exp_Ch9 is
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;
diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads
index 5ba5b9fdd07..3656ac7cdaa 100644
--- a/gcc/ada/exp_ch9.ads
+++ b/gcc/ada/exp_ch9.ads
@@ -55,6 +55,12 @@ package Exp_Ch9 is
-- 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
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index 2c812e81d14..ebdc7ce1c23 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -39,6 +39,10 @@ with Uname; use Uname;
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 --
--------------------------------
@@ -898,6 +902,15 @@ package body Restrict is
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 --
-------------------------------
@@ -1574,6 +1587,15 @@ package body Restrict is
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 --
----------------------------------
diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads
index e0c6bbacf10..bcea1158e9b 100644
--- a/gcc/ada/restrict.ads
+++ b/gcc/ada/restrict.ads
@@ -422,6 +422,10 @@ package Restrict is
-- 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;
@@ -505,6 +509,10 @@ package Restrict is
-- 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 --
----------------------------------------------
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 2431b260e67..149776c212a 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -924,7 +924,6 @@ package body Sem_Ch3 is
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);
@@ -5418,6 +5417,7 @@ package body Sem_Ch3 is
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
@@ -5701,6 +5701,7 @@ package body Sem_Ch3 is
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))
@@ -12358,6 +12359,7 @@ package body Sem_Ch3 is
-- 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
@@ -12393,11 +12395,18 @@ package body Sem_Ch3 is
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.
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 51724ff0ea3..8ded5ad0553 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -51,7 +51,6 @@ with Nmake; use Nmake;
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;
@@ -2928,22 +2927,8 @@ package body Sem_Ch6 is
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));
@@ -8566,6 +8551,9 @@ package body Sem_Ch6 is
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),
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index a32bb9bf241..eb374c4bb7a 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10679,6 +10679,55 @@ package body Sem_Prag is
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
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 203cada0956..31e03fda4dd 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6119,14 +6119,14 @@ package body Sem_Util is
-- 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))
@@ -6137,6 +6137,15 @@ package body Sem_Util is
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 --
-------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index ebc917512bf..a7ca0f7a092 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -574,9 +574,10 @@ package Sem_Util is
-- 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.
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2020-08-22 22:48 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-08-22 22:46 [gcc/devel/autopar_devel] [Ada] Crash in tagged type constructor with task components Giuliano Belinassi
-- strict thread matches above, loose matches on Subject: below --
2020-08-22 22:48 Giuliano Belinassi
2020-08-22 22:43 Giuliano Belinassi
2020-08-22 22:38 Giuliano Belinassi
2020-08-22 22:37 Giuliano Belinassi
2020-08-22 22:37 Giuliano Belinassi
2020-08-22 22:34 Giuliano Belinassi
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).