From 640ad9c221fe9bac7bff0d60a8aa094f09538bec Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Wed, 14 Nov 2018 11:40:47 +0000 Subject: [PATCH] [Ada] Limited function violates No_Exception_Propagation This patch suppresses the generation of raise statements in the context of build-in-place and elaboration checks for primitives of tagged types when exceptions cannot be used. 2018-11-14 Hristian Kirtchev gcc/ada/ * checks.adb (Install_Primitive_Elaboration_Check): Do not create the check when exceptions cannot be used. * exp_ch6.adb (Expand_N_Extended_Return_Statement): Do not raise Program_Errror when exceptions cannot be used. Analyze the generated code with all checks suppressed. * exp_ch7.adb (Build_Finalizer): Remove the declaration of Exceptions_OK. (Make_Deep_Array_Body): Remove the declaration of Exceptions_OK. (Make_Deep_Record_Body): Remove the declaration of Exceptions_OK. (Process_Transients_In_Scope): Remove the declaration of Exceptions_OK. * exp_util.adb (Exceptions_In_Finalization_OK): Renamed to Exceptions_OK. * exp_util.ads (Exceptions_In_Finalization_OK): Renamed to Exceptions_OK. gcc/testsuite/ * gnat.dg/bip_exception.adb, gnat.dg/bip_exception.ads, gnat.dg/bip_exception_pkg.ads: New testcase. From-SVN: r266115 --- gcc/ada/ChangeLog | 19 +++++++++++++++++++ gcc/ada/checks.adb | 6 ++++++ gcc/ada/exp_ch6.adb | 19 +++++++++++++++---- gcc/ada/exp_ch7.adb | 8 +------- gcc/ada/exp_util.adb | 10 +++++----- gcc/ada/exp_util.ads | 6 +++--- gcc/testsuite/ChangeLog | 5 +++++ gcc/testsuite/gnat.dg/bip_exception.adb | 17 +++++++++++++++++ gcc/testsuite/gnat.dg/bip_exception.ads | 20 ++++++++++++++++++++ gcc/testsuite/gnat.dg/bip_exception_pkg.ads | 11 +++++++++++ 10 files changed, 102 insertions(+), 19 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/bip_exception.adb create mode 100644 gcc/testsuite/gnat.dg/bip_exception.ads create mode 100644 gcc/testsuite/gnat.dg/bip_exception_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cea73e9451f..dda456ea45f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2018-11-14 Hristian Kirtchev + + * checks.adb (Install_Primitive_Elaboration_Check): Do not + create the check when exceptions cannot be used. + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Do not raise + Program_Errror when exceptions cannot be used. Analyze the + generated code with all checks suppressed. + * exp_ch7.adb (Build_Finalizer): Remove the declaration of + Exceptions_OK. + (Make_Deep_Array_Body): Remove the declaration of Exceptions_OK. + (Make_Deep_Record_Body): Remove the declaration of + Exceptions_OK. + (Process_Transients_In_Scope): Remove the declaration of + Exceptions_OK. + * exp_util.adb (Exceptions_In_Finalization_OK): Renamed to + Exceptions_OK. + * exp_util.ads (Exceptions_In_Finalization_OK): Renamed to + Exceptions_OK. + 2018-11-14 Hristian Kirtchev * exp_ch4.adb (Expand_N_Op_Eq): Remove duplicated code and use diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 61768865ce1..e7048ecc4ef 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7960,6 +7960,12 @@ package body Checks is elsif Restriction_Active (No_Elaboration_Code) then return; + -- Do not generate an elaboration check if exceptions cannot be used, + -- caught, or propagated. + + elsif not Exceptions_OK then + return; + -- Do not consider subprograms which act as compilation units, because -- they cannot be the target of a dispatching call. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 076e0c28e50..e3914799a42 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5099,6 +5099,7 @@ package body Exp_Ch6 is Alloc_Obj_Id : Entity_Id; Alloc_Obj_Decl : Node_Id; Alloc_If_Stmt : Node_Id; + Guard_Except : Node_Id; Heap_Allocator : Node_Id; Pool_Decl : Node_Id; Pool_Allocator : Node_Id; @@ -5298,6 +5299,18 @@ package body Exp_Ch6 is (Return_Statement_Entity (N)); Set_Enclosing_Sec_Stack_Return (N); + -- Guard against poor expansion on the caller side by + -- using a raise statement to catch out-of-range values + -- of formal parameter BIP_Alloc_Form. + + if Exceptions_OK then + Guard_Except := + Make_Raise_Program_Error (Loc, + Reason => PE_Build_In_Place_Mismatch); + else + Guard_Except := Make_Null_Statement (Loc); + end if; + -- Create an if statement to test the BIP_Alloc_Form -- formal and initialize the access object to either the -- BIP_Object_Access formal (BIP_Alloc_Form = @@ -5400,9 +5413,7 @@ package body Exp_Ch6 is -- Raise Program_Error if it's none of the above; -- this is a compiler bug. - Else_Statements => New_List ( - Make_Raise_Program_Error (Loc, - Reason => PE_Build_In_Place_Mismatch))); + Else_Statements => New_List (Guard_Except)); -- If a separate initialization assignment was created -- earlier, append that following the assignment of the @@ -5477,7 +5488,7 @@ package body Exp_Ch6 is Set_Comes_From_Extended_Return_Statement (Return_Stmt); Rewrite (N, Result); - Analyze (N); + Analyze (N, Suppress => All_Checks); end Expand_N_Extended_Return_Statement; ---------------------------- diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index ee04b22254a..b192956a678 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1337,7 +1337,7 @@ package body Exp_Ch7 is or else (Present (Clean_Stmts) and then Is_Non_Empty_List (Clean_Stmts)); - Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK; + For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body; For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration; For_Package : constant Boolean := @@ -5328,8 +5328,6 @@ package body Exp_Ch7 is Last_Object : Node_Id; Related_Node : Node_Id) is - Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK; - Must_Hook : Boolean := False; -- Flag denoting whether the context requires transient object -- export to the outer finalizer. @@ -5997,8 +5995,6 @@ package body Exp_Ch7 is (Prim : Final_Primitives; Typ : Entity_Id) return List_Id is - Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK; - function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id; -- Create the statements necessary to adjust or finalize an array of @@ -6829,8 +6825,6 @@ package body Exp_Ch7 is Typ : Entity_Id; Is_Local : Boolean := False) return List_Id is - Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK; - function Build_Adjust_Statements (Typ : Entity_Id) return List_Id; -- Build the statements necessary to adjust a record type. The type may -- have discriminants and contain variant parts. Generate: diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b24cab7a2f2..1ef342d318f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4940,17 +4940,17 @@ package body Exp_Util is end if; end Evolve_Or_Else; - ----------------------------------- - -- Exceptions_In_Finalization_OK -- - ----------------------------------- + ------------------- + -- Exceptions_OK -- + ------------------- - function Exceptions_In_Finalization_OK return Boolean is + function Exceptions_OK return Boolean is begin return not (Restriction_Active (No_Exception_Handlers) or else Restriction_Active (No_Exception_Propagation) or else Restriction_Active (No_Exceptions)); - end Exceptions_In_Finalization_OK; + end Exceptions_OK; ----------------------------------------- -- Expand_Static_Predicates_In_Choices -- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index b5e2a7bbe14..7c2d9b72ec6 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -544,9 +544,9 @@ package Exp_Util is -- indicating that no checks were required). The Sloc field of the -- constructed N_Or_Else node is copied from Cond1. - function Exceptions_In_Finalization_OK return Boolean; - -- Determine whether the finalization machinery can safely add exception - -- handlers and recovery circuitry. + function Exceptions_OK return Boolean; + -- Determine whether exceptions are allowed to be caught, propagated, or + -- raised. procedure Expand_Static_Predicates_In_Choices (N : Node_Id); -- N is either a case alternative or a variant. The Discrete_Choices field diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 43bfc8a78a4..3fddcce9510 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-11-14 Hristian Kirtchev + + * gnat.dg/bip_exception.adb, gnat.dg/bip_exception.ads, + gnat.dg/bip_exception_pkg.ads: New testcase. + 2018-11-14 Hristian Kirtchev * gnat.dg/equal4.adb, gnat.dg/equal4.ads, diff --git a/gcc/testsuite/gnat.dg/bip_exception.adb b/gcc/testsuite/gnat.dg/bip_exception.adb new file mode 100644 index 00000000000..1ab24a53c6d --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_exception.adb @@ -0,0 +1,17 @@ +-- { dg-do compile } +-- { dg-options "-gnatwa" } + +package body BIP_Exception is + package body Constructors is + function Initialize return T_C4_Scheduler is + begin + return T_C4_Scheduler'(T_Super with null record); + end Initialize; + end Constructors; + + overriding procedure V_Run (This : in T_C4_Scheduler) is + pragma Unreferenced (This); + begin + null; + end V_Run; +end BIP_Exception; diff --git a/gcc/testsuite/gnat.dg/bip_exception.ads b/gcc/testsuite/gnat.dg/bip_exception.ads new file mode 100644 index 00000000000..da3e240e958 --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_exception.ads @@ -0,0 +1,20 @@ +pragma Restrictions (No_Exception_Propagation); +with BIP_Exception_Pkg; + +package BIP_Exception is + type T_C4_Scheduler is new BIP_Exception_Pkg.T_Process with private; + type T_C4_Scheduler_Class_Access is access all T_C4_Scheduler'Class; + + package Constructors is + function Initialize return T_C4_Scheduler; + end Constructors; + + overriding procedure V_Run (This : in T_C4_Scheduler); + pragma Suppress (Elaboration_Check, V_Run); + +private + package Super renames BIP_Exception_Pkg; + subtype T_Super is Super.T_Process; + + type T_C4_Scheduler is new T_Super with null record; +end BIP_Exception; diff --git a/gcc/testsuite/gnat.dg/bip_exception_pkg.ads b/gcc/testsuite/gnat.dg/bip_exception_pkg.ads new file mode 100644 index 00000000000..f5f22abbcd0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_exception_pkg.ads @@ -0,0 +1,11 @@ +pragma Restrictions (No_Exception_Propagation); + +package BIP_Exception_Pkg is + type T_Process is abstract tagged limited private; + type T_Process_Class_Access is access all T_Process'Class; + + procedure V_Run (This : in T_Process) is abstract; + +private + type T_Process is abstract tagged limited null record; +end BIP_Exception_Pkg; -- 2.30.2