From 0d66b5969fec023f9aa6c297ba8550f5621cb2ea Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 18 Apr 2016 11:57:49 +0200 Subject: [PATCH] [multiple changes] 2016-04-18 Ed Schonberg * sem_disp.adb (Check_Dispatching_Call): Major rewriting to handle some complex cases of tag indeterminate calls that are actuals in other dispatching calls that are themselves tag indeterminate. (Check_Dispatching_Context): Add parameter to support recursive check for an enclosing construct that may provide a tag for a tag-indeterminate call. 2016-04-18 Hristian Kirtchev * sem_prag.adb (Analyze_Depends_In_Decl_Part): Add global variables Task_Input_Seen and Task_Output_Seen. (Analyze_Global_Item): Detect an illegal use of the current instance of a single protected/task type in a global annotation. (Analyze_Input_Output): Inputs and output related to the current instance of a task unit are now tracked. (Check_Usage): Require the presence of the current instance of a task unit only when one input/output is available. (Current_Task_Instance_Seen): New routine. (Is_CCT_Instance): New parameter profile. Update the comment on usage. The routine now properly recognizes several cases related to single protected/task types. 2016-04-18 Hristian Kirtchev * freeze.adb (Freeze_Entity): Use New_Freeze_Node to create a brand new freeze node. This handles a case where an ignored Ghost context is freezing something which is not ignored Ghost and whose freeze node should not be removed from the tree. (New_Freeze_Node): New routine. 2016-04-18 Jerome Lambourg * sigtramp.h (__gnat_set_is_vxsim) New function to tell sigtramp-vxworks to handle vxsim signal contexts. * sigtramp-vxworks.c (__gnat_sigtramp) Take into account the differences in the sigcontext structure between the expected regular x86 or x86_64 ones and the ones received in case of exexution on the vxworks simulator. * init.c: also compute is_vxsim in case of x86_64-vx7 target. Provide this information to sigtramp-vxworks.c. Remove the old mechanism for vxsim. * init-vxsim.c, sigtramp-vxworks-vxsim.c: remove, now obsolete. 2016-04-18 Eric Botcazou * exp_ch3.adb (Inline_Init_Proc): New function returning whether the initialization procedure of a type should be inlined. Return again True for controlled type themselves. (Build_Array_Init_Proc): Call it to set Set_Is_Inlined on Init_Proc. (Build_Record_Init_Proc): Likewise. From-SVN: r235110 --- gcc/ada/ChangeLog | 55 +++++++++++ gcc/ada/exp_ch3.adb | 58 +++++++---- gcc/ada/freeze.adb | 42 +++++++- gcc/ada/init-vxsim.c | 62 ------------ gcc/ada/init.c | 44 +++------ gcc/ada/sem_disp.adb | 182 +++++++++++++++++++++------------- gcc/ada/sem_prag.adb | 205 ++++++++++++++++++++++++++++++++------- gcc/ada/sigtramp-vxworks-vxsim.c | 141 --------------------------- gcc/ada/sigtramp-vxworks.c | 76 ++++++++++++--- gcc/ada/sigtramp.h | 13 +-- 10 files changed, 497 insertions(+), 381 deletions(-) delete mode 100644 gcc/ada/init-vxsim.c delete mode 100644 gcc/ada/sigtramp-vxworks-vxsim.c diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1cbbd4a..c4e73d1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,58 @@ +2016-04-18 Ed Schonberg + + * sem_disp.adb (Check_Dispatching_Call): Major rewriting to + handle some complex cases of tag indeterminate calls that are + actuals in other dispatching calls that are themselves tag + indeterminate. + (Check_Dispatching_Context): Add parameter to support recursive + check for an enclosing construct that may provide a tag for a + tag-indeterminate call. + +2016-04-18 Hristian Kirtchev + + * sem_prag.adb (Analyze_Depends_In_Decl_Part): + Add global variables Task_Input_Seen and Task_Output_Seen. + (Analyze_Global_Item): Detect an illegal use of the current + instance of a single protected/task type in a global annotation. + (Analyze_Input_Output): Inputs and output related to the current + instance of a task unit are now tracked. + (Check_Usage): Require + the presence of the current instance of a task unit only when + one input/output is available. (Current_Task_Instance_Seen): + New routine. + (Is_CCT_Instance): New parameter profile. Update + the comment on usage. The routine now properly recognizes several + cases related to single protected/task types. + +2016-04-18 Hristian Kirtchev + + * freeze.adb (Freeze_Entity): Use New_Freeze_Node + to create a brand new freeze node. This handles a case where an + ignored Ghost context is freezing something which is not ignored + Ghost and whose freeze node should not be removed from the tree. + (New_Freeze_Node): New routine. + +2016-04-18 Jerome Lambourg + + * sigtramp.h (__gnat_set_is_vxsim) New function to + tell sigtramp-vxworks to handle vxsim signal contexts. * + sigtramp-vxworks.c (__gnat_sigtramp) Take into account the + differences in the sigcontext structure between the expected + regular x86 or x86_64 ones and the ones received in case of + exexution on the vxworks simulator. + * init.c: also compute is_vxsim in case of x86_64-vx7 target. Provide + this information to sigtramp-vxworks.c. Remove the old mechanism for + vxsim. + * init-vxsim.c, sigtramp-vxworks-vxsim.c: remove, now obsolete. + +2016-04-18 Eric Botcazou + + * exp_ch3.adb (Inline_Init_Proc): New function returning + whether the initialization procedure of a type should be + inlined. Return again True for controlled type themselves. + (Build_Array_Init_Proc): Call it to set Set_Is_Inlined on Init_Proc. + (Build_Record_Init_Proc): Likewise. + 2016-04-18 Arnaud Charlet * gnatvsn.ads (Library_Version): Bump to 7. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 869220f..a858f75 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -226,6 +226,9 @@ package body Exp_Ch3 is -- -- The caller must append additional entries for discriminants if required. + function Inline_Init_Proc (Typ : Entity_Id) return Boolean; + -- Returns true if the initialization procedure of Typ should be inlined + function In_Runtime (E : Entity_Id) return Boolean; -- Check if E is defined in the RTL (in a child of Ada or System). Used -- to avoid to bring in the overhead of _Input, _Output for tagged types. @@ -756,14 +759,10 @@ package body Exp_Ch3 is Set_Debug_Info_Off (Proc_Id); end if; - -- Set inlined unless tasks are around, in which case we do not - -- want to inline, because nested stuff may cause difficulties in - -- inter-unit inlining, and furthermore there is in any case no - -- point in inlining such complex init procs. + -- Set Inlined on Init_Proc if it is set on the Init_Proc of the + -- component type itself (see also Build_Record_Init_Proc). - if not Has_Task (Proc_Id) then - Set_Is_Inlined (Proc_Id); - end if; + Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type)); -- Associate Init_Proc with type, and determine if the procedure -- is null (happens because of the Initialize_Scalars pragma case, @@ -3592,21 +3591,8 @@ package body Exp_Ch3 is Build_Offset_To_Top_Functions; Build_CPP_Init_Procedure; Build_Init_Procedure; - Set_Is_Public (Proc_Id, Is_Public (Rec_Ent)); - - -- The initialization of protected records is not worth inlining. - -- In addition, when compiled for another unit for inlining purposes, - -- it may make reference to entities that have not been elaborated - -- yet. Similar considerations apply to task types and types that - -- need finalization. - - if not Is_Concurrent_Type (Rec_Type) - and then not Has_Task (Rec_Type) - and then not Needs_Finalization (Rec_Type) - then - Set_Is_Inlined (Proc_Id); - end if; + Set_Is_Public (Proc_Id, Is_Public (Rec_Ent)); Set_Is_Internal (Proc_Id); Set_Has_Completion (Proc_Id); @@ -3614,6 +3600,8 @@ package body Exp_Ch3 is Set_Debug_Info_Off (Proc_Id); end if; + Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type)); + -- Do not build an aggregate if Modify_Tree_For_C, this isn't -- needed and may generate early references to non frozen types -- since we expand aggregate much more systematically. @@ -8230,6 +8218,34 @@ package body Exp_Ch3 is end if; end Has_New_Non_Standard_Rep; + ---------------------- + -- Inline_Init_Proc -- + ---------------------- + + function Inline_Init_Proc (Typ : Entity_Id) return Boolean is + begin + -- The initialization proc of protected records is not worth inlining. + -- In addition, when compiled for another unit for inlining purposes, + -- it may make reference to entities that have not been elaborated yet. + -- The initialization proc of records that need finalization contains + -- a nested clean-up procedure that makes it impractical to inline as + -- well, except for simple controlled types themselves. And similar + -- considerations apply to task types. + + if Is_Concurrent_Type (Typ) then + return False; + + elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then + return False; + + elsif Has_Task (Typ) then + return False; + + else + return True; + end if; + end Inline_Init_Proc; + ---------------- -- In_Runtime -- ---------------- diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 93fd53c..736535e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1997,6 +1997,9 @@ package body Freeze is -- call, but rather must go in the package holding the function, so that -- the backend can process it in the proper context. + function New_Freeze_Node return Node_Id; + -- Create a new freeze node for entity E + procedure Wrap_Imported_Subprogram (E : Entity_Id); -- If E is an entity for an imported subprogram with pre/post-conditions -- then this procedure will create a wrapper to ensure that proper run- @@ -4589,6 +4592,39 @@ package body Freeze is Append_List (Result, Decls); end Late_Freeze_Subprogram; + --------------------- + -- New_Freeze_Node -- + --------------------- + + function New_Freeze_Node return Node_Id is + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + Result : Node_Id; + + begin + -- Handle the case where an ignored Ghost subprogram freezes the type + -- of one of its formals. The type can either be non-Ghost or checked + -- Ghost. Since the freeze node for the type is generated in the + -- context of the subprogram, the node will be incorrectly flagged as + -- ignored Ghost and erroneously removed from the tree. + + -- type Typ is ...; + -- procedure Ignored_Ghost_Proc (Formal : Typ) with Ghost; + + -- Reset the Ghost mode to "none". This preserves the freeze node. + + if Ghost_Mode = Ignore + and then not Is_Ignored_Ghost_Entity (E) + and then not Is_Ignored_Ghost_Node (E) + then + Ghost_Mode := None; + end if; + + Result := New_Node (N_Freeze_Entity, Loc); + + Ghost_Mode := Save_Ghost_Mode; + return Result; + end New_Freeze_Node; + ------------------------------ -- Wrap_Imported_Subprogram -- ------------------------------ @@ -6281,7 +6317,7 @@ package body Freeze is Set_Sloc (F_Node, Loc); else - F_Node := New_Node (N_Freeze_Entity, Loc); + F_Node := New_Freeze_Node; Set_Freeze_Node (E, F_Node); Set_Access_Types_To_Process (F_Node, No_Elist); Set_TSS_Elist (F_Node, No_Elist); @@ -6299,9 +6335,7 @@ package body Freeze is -- subtypes can only be elaborated after the type itself, and they -- need an itype reference. - if Ekind (E) = E_Record_Type - and then Has_Discriminants (E) - then + if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then declare Comp : Entity_Id; IR : Node_Id; diff --git a/gcc/ada/init-vxsim.c b/gcc/ada/init-vxsim.c deleted file mode 100644 index 9466dbc..0000000 --- a/gcc/ada/init-vxsim.c +++ /dev/null @@ -1,62 +0,0 @@ -/**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * I N I T - V X S I M * - * * - * C Implementation File * - * * - * Copyright (C) 1992-2015, Free Software Foundation, Inc. * - * * - * GNAT is free software; you can redistribute it and/or modify it under * - * terms of the GNU General Public License as published by the Free Soft- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. * - * * - * As a special exception under Section 7 of GPL version 3, you are granted * - * additional permissions described in the GCC Runtime Library Exception, * - * version 3.1, as published by the Free Software Foundation. * - * * - * You should have received a copy of the GNU General Public License and * - * a copy of the GCC Runtime Library Exception along with this program; * - * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - -/* This file is an addition to init.c that must be compiled with the CPU - specified for running under vxsim for x86-vxworks6, as the signal context - structure is different for vxsim vs. real hardware. */ - -#undef CPU -#define CPU __VXSIM_CPU__ - -#include "vxWorks.h" -#include "tconfig.h" - -#include -#include - -#ifndef __RTP__ -#include -#include -#endif - -extern void -__gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, - void *sc ATTRIBUTE_UNUSED); - -/* Process the vxsim signal context. */ -void -__gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc) -{ - #include "sigtramp.h" - - __gnat_sigtramp_vxsim (sig, (void *)si, (void *)sc, - (__sigtramphandler_t *)&__gnat_map_signal); -} diff --git a/gcc/ada/init.c b/gcc/ada/init.c index ae9b58e..43ea1e7 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1705,10 +1705,12 @@ __gnat_install_handler (void) #include #include -#if defined (__i386__) && !defined (VTHREADS) +#if (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS) #include #endif +#include "sigtramp.h" + #ifndef __RTP__ #include #include @@ -1814,7 +1816,9 @@ __gnat_clear_exception_count (void) /* Handle different SIGnal to exception mappings in different VxWorks versions. */ void -__gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *sc) +__gnat_map_signal (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *sc ATTRIBUTE_UNUSED) { struct Exception_Data *exception; const char *msg; @@ -1924,14 +1928,6 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *sc) Raise_From_Signal_Handler (exception, msg); } -#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR < 7 - -extern void -__gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc); - -static int is_vxsim = 0; -#endif - #if defined (ARMEL) && (_WRS_VXWORKS_MAJOR >= 7) /* ARM-vx7 case with arm unwinding exceptions */ @@ -2015,19 +2011,8 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) __gnat_adjust_context_for_raise (sig, sc); #endif -#if defined (__i386__) && !defined (VTHREADS) && (__WRS_VXWORKS_MAJOR < 7) - /* On x86, the vxsim signal context is subtly different and is processeed - by a handler compiled especially for vxsim. - Vxsim is not supported anymore on our vxworks-7 port. */ - - if (is_vxsim) - __gnat_vxsim_error_handler (sig, si, sc); -#endif - -# include "sigtramp.h" - __gnat_sigtramp (sig, (void *)si, (void *)sc, - (__sigtramphandler_t *)&__gnat_map_signal); + (__sigtramphandler_t *)&__gnat_map_signal); #else __gnat_map_signal (sig, si, sc); @@ -2057,7 +2042,6 @@ void __gnat_install_handler (void) { struct sigaction act; - char *model ATTRIBUTE_UNUSED; /* Setup signal handler to map synchronous signals to appropriate exceptions. Make sure that the handler isn't interrupted by another @@ -2108,13 +2092,17 @@ __gnat_install_handler (void) trap_0_entry->inst_fourth = 0xa1480000; #endif -#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR != 7 +#ifdef __HANDLE_VXSIM_SC /* By experiment, found that sysModel () returns the following string prefix for vxsim when running on Linux and Windows. */ - model = sysModel (); - if ((strncmp (model, "Linux", 5) == 0) - || (strncmp (model, "Windows", 7) == 0)) - is_vxsim = 1; + { + char *model = sysModel (); + if ((strncmp (model, "Linux", 5) == 0) + || (strncmp (model, "Windows", 7) == 0) + || (strncmp (model, "SIMLINUX", 8) == 0) /* vx7 */ + || (strncmp (model, "SIMWINDOWS", 10) == 0)) /* ditto */ + __gnat_set_is_vxsim (TRUE); + } #endif __gnat_handler_installed = 1; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index d2396a3..2d9a746 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -409,7 +409,7 @@ package body Sem_Disp is -- fact direct. This routine detects the above case and modifies the -- call accordingly. - procedure Check_Dispatching_Context; + procedure Check_Dispatching_Context (Call : Node_Id); -- If the call is tag-indeterminate and the entity being called is -- abstract, verify that the context is a call that will eventually -- provide a tag for dispatching, or has provided one already. @@ -508,10 +508,9 @@ package body Sem_Disp is -- Check_Dispatching_Context -- ------------------------------- - procedure Check_Dispatching_Context is - Subp : constant Entity_Id := Entity (Name (N)); + procedure Check_Dispatching_Context (Call : Node_Id) is + Subp : constant Entity_Id := Entity (Name (Call)); Typ : constant Entity_Id := Etype (Subp); - Par : Node_Id; procedure Abstract_Context_Error; -- Error for abstract call dispatching on result is not dispatching @@ -536,11 +535,15 @@ package body Sem_Disp is end if; end Abstract_Context_Error; + -- Local variables + + Par : Node_Id; + -- Start of processing for Check_Dispatching_Context begin if Is_Abstract_Subprogram (Subp) - and then No (Controlling_Argument (N)) + and then No (Controlling_Argument (Call)) then if Present (Alias (Subp)) and then not Is_Abstract_Subprogram (Alias (Subp)) @@ -565,7 +568,8 @@ package body Sem_Disp is -- but will be legal in overridings of the operation. elsif In_Spec_Expression - and then Is_Subprogram (Current_Scope) + and then (Is_Subprogram (Current_Scope) + or else Chars (Current_Scope) = Name_Postcondition) and then ((Nkind (Parent (Current_Scope)) = N_Procedure_Specification and then Null_Present (Parent (Current_Scope))) @@ -588,82 +592,110 @@ package body Sem_Disp is if not Is_Tagged_Type (Typ) and then not - (Ekind (Typ) = E_Anonymous_Access_Type - and then Is_Tagged_Type (Designated_Type (Typ))) + (Ekind (Typ) = E_Anonymous_Access_Type + and then Is_Tagged_Type (Designated_Type (Typ))) then Abstract_Context_Error; return; end if; - Par := Parent (N); + Par := Parent (Call); if Nkind (Par) = N_Parameter_Association then Par := Parent (Par); end if; - while Present (Par) loop - if Nkind_In (Par, N_Function_Call, - N_Procedure_Call_Statement) - and then Is_Entity_Name (Name (Par)) - then - declare - Enc_Subp : constant Entity_Id := Entity (Name (Par)); - A : Node_Id; - F : Entity_Id; - - begin - -- Find formal for which call is the actual, and is - -- a controlling argument. - - F := First_Formal (Enc_Subp); - A := First_Actual (Par); - - while Present (F) loop - if Is_Controlling_Formal (F) - and then (N = A or else Parent (N) = A) - then - return; - end if; + if Nkind (Par) = N_Qualified_Expression + or else Nkind (Par) = N_Unchecked_Type_Conversion + then + Par := Parent (Par); + end if; - Next_Formal (F); - Next_Actual (A); - end loop; + if Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Par)) + then + declare + Enc_Subp : constant Entity_Id := Entity (Name (Par)); + A : Node_Id; + F : Entity_Id; + Control : Entity_Id; + Ret_Type : Entity_Id; - Error_Msg_N - ("call to abstract function must be dispatching", N); - return; - end; + begin + -- Find controlling formal that can provide tag for the + -- tag-indeterminate actual. The corresponding actual + -- must be the corresponding class-wide type. - -- For equalitiy operators, one of the operands must be - -- statically or dynamically tagged. + F := First_Formal (Enc_Subp); + A := First_Actual (Par); - elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then - if N = Right_Opnd (Par) - and then Is_Tag_Indeterminate (Left_Opnd (Par)) - then - Abstract_Context_Error; + -- Find controlling type of call. Dereference if function + -- returns an access type. - elsif N = Left_Opnd (Par) - and then Is_Tag_Indeterminate (Right_Opnd (Par)) - then - Abstract_Context_Error; + Ret_Type := Etype (Call); + if Is_Access_Type (Etype (Call)) then + Ret_Type := Designated_Type (Ret_Type); end if; - return; + while Present (F) loop + Control := Etype (A); - elsif Nkind (Par) = N_Assignment_Statement then - return; + if Is_Access_Type (Control) then + Control := Designated_Type (Control); + end if; + + if Is_Controlling_Formal (F) + and then not (Call = A or else Parent (Call) = A) + and then Control = Class_Wide_Type (Ret_Type) + then + return; + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; - elsif Nkind (Par) = N_Qualified_Expression - or else Nkind (Par) = N_Unchecked_Type_Conversion + if Nkind (Par) = N_Function_Call + and then Is_Tag_Indeterminate (Par) + then + -- The parent may be an actual of an enclosing call + + Check_Dispatching_Context (Par); + return; + + else + Error_Msg_N + ("call to abstract function must be dispatching", + Call); + return; + end if; + end; + + -- For equality operators, one of the operands must be + -- statically or dynamically tagged. + + elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then + if N = Right_Opnd (Par) + and then Is_Tag_Indeterminate (Left_Opnd (Par)) then - Par := Parent (Par); + Abstract_Context_Error; - else + elsif N = Left_Opnd (Par) + and then Is_Tag_Indeterminate (Right_Opnd (Par)) + then Abstract_Context_Error; - return; end if; - end loop; + + return; + + -- The left-hand side of an assignment provides the tag + + elsif Nkind (Par) = N_Assignment_Statement then + return; + + else + Abstract_Context_Error; + end if; end if; end if; end Check_Dispatching_Context; @@ -813,11 +845,12 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - Check_Dispatching_Context; + Check_Dispatching_Context (N); + + elsif Nkind (N) /= N_Function_Call then - else -- The call is not dispatching, so check that there aren't any - -- tag-indeterminate abstract calls left. + -- tag-indeterminate abstract calls left among its actuals. Actual := First_Actual (N); while Present (Actual) loop @@ -836,7 +869,7 @@ package body Sem_Disp is then Func := Empty; - -- Ditto if it is an explicit dereference. + -- Ditto if it is an explicit dereference elsif Nkind (Original_Node (Actual)) = N_Explicit_Dereference then @@ -848,28 +881,41 @@ package body Sem_Disp is else Func := Entity (Name (Original_Node - (Expression (Original_Node (Actual))))); + (Expression (Original_Node (Actual))))); end if; if Present (Func) and then Is_Abstract_Subprogram (Func) then Error_Msg_N - ("call to abstract function must be dispatching", N); + ("call to abstract function must be dispatching", + Actual); end if; end if; Next_Actual (Actual); end loop; - Check_Dispatching_Context; + Check_Dispatching_Context (N); + return; + + elsif Nkind (Parent (N)) in N_Subexpr then + Check_Dispatching_Context (N); + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Class_Wide_Type (Etype (Name (Parent (N)))) + then + return; + + elsif Is_Abstract_Subprogram (Subp_Entity) then + Check_Dispatching_Context (N); + return; end if; else - -- If dispatching on result, the enclosing call, if any, will -- determine the controlling argument. Otherwise this is the -- primitive operation of the root type. - Check_Dispatching_Context; + Check_Dispatching_Context (N); end if; end Check_Dispatching_Call; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8cafd56d..534681a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -245,10 +245,13 @@ package body Sem_Prag is -- Determine whether dependency clause Clause is surrounded by extra -- parentheses. If this is the case, issue an error message. - function Is_CCT_Instance (Ref : Node_Id) return Boolean; + function Is_CCT_Instance + (Ref_Id : Entity_Id; + Context_Id : Entity_Id) return Boolean; -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] - -- Global. Determine whether reference Ref denotes the current instance of - -- a concurrent type. + -- Global. Determine whether entity Ref_Id denotes the current instance of + -- a concurrent type. Context_Id denotes the associated context where the + -- pragma appears. function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of @@ -559,6 +562,10 @@ package body Sem_Prag is -- Two lists containing the full set of inputs and output of the related -- subprograms. Note that these lists contain both nodes and entities. + Task_Input_Seen : Boolean := False; + Task_Output_Seen : Boolean := False; + -- Flags used to track the implicit dependence of a task unit on itself + procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id); -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind -- to the name buffer. The individual kinds are as follows: @@ -590,7 +597,7 @@ package body Sem_Prag is Item_Id : Entity_Id; Is_Input : Boolean; Self_Ref : Boolean); - -- Ensure that an item fulfils its designated input and/or output role + -- Ensure that an item fulfills its designated input and/or output role -- as specified by pragma Global (if any) or the enclosing context. If -- this is not the case, emit an error. Item and Item_Id denote the -- attributes of an item. Flag Is_Input should be set when item comes @@ -763,10 +770,31 @@ package body Sem_Prag is Null_Seen : in out Boolean; Non_Null_Seen : in out Boolean) is + procedure Current_Task_Instance_Seen; + -- Set the appropriate global flag when the current instance of a + -- task unit is encountered. + + -------------------------------- + -- Current_Task_Instance_Seen -- + -------------------------------- + + procedure Current_Task_Instance_Seen is + begin + if Is_Input then + Task_Input_Seen := True; + else + Task_Output_Seen := True; + end if; + end Current_Task_Instance_Seen; + + -- Local variables + Is_Output : constant Boolean := not Is_Input; Grouped : Node_Id; Item_Id : Entity_Id; + -- Start of processing for Analyze_Input_Output + begin -- Multiple input or output items appear as an aggregate @@ -899,18 +927,45 @@ package body Sem_Prag is Ekind_In (Item_Id, E_Abstract_State, E_Variable) then - -- The item denotes a concurrent type, but it is not the - -- current instance of an enclosing concurrent type. + -- The item denotes a concurrent type. Note that single + -- protected/task types are not considered here because + -- they behave as objects in the context of pragma + -- [Refined_]Depends. + + if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then + + -- This use is legal as long as the concurrent type is + -- the current instance of an enclosing type. + + if Is_CCT_Instance (Item_Id, Spec_Id) then - if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) - and then not Is_CCT_Instance (Item) + -- The dependence of a task unit on itself is + -- implicit and may or may not be explicitly + -- specified (SPARK RM 6.1.4). + + if Ekind (Item_Id) = E_Task_Type then + Current_Task_Instance_Seen; + end if; + + -- Otherwise this is not the current instance + + else + SPARK_Msg_N + ("invalid use of subtype mark in dependency " + & "relation", Item); + end if; + + -- The dependency of a task unit on itself is implicit + -- and may or may not be explicitly specified + -- (SPARK RM 6.1.4). + + elsif Is_Single_Task_Object (Item_Id) + and then Is_CCT_Instance (Item_Id, Spec_Id) then - SPARK_Msg_N - ("invalid use of subtype mark in dependency " - & "relation", Item); + Current_Task_Instance_Seen; end if; - -- Ensure that the item fulfils its role as input and/or + -- Ensure that the item fulfills its role as input and/or -- output as specified by pragma Global or the enclosing -- context. @@ -1427,14 +1482,31 @@ package body Sem_Prag is if Present (Item_Id) and then not Contains (Used_Items, Item_Id) then - -- The current instance of a concurrent type behaves as a - -- formal parameter (SPARK RM 6.1.4). + if Is_Formal (Item_Id) then + Usage_Error (Item_Id); - if Is_Formal (Item_Id) - or else Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) + -- The current instance of a protected type behaves as a formal + -- parameter (SPARK RM 6.1.4). + + elsif Ekind (Item_Id) = E_Protected_Type + or else Is_Single_Protected_Object (Item_Id) then Usage_Error (Item_Id); + -- The current instance of a task type behaves as a formal + -- parameter (SPARK RM 6.1.4). + + elsif Ekind (Item_Id) = E_Task_Type + or else Is_Single_Task_Object (Item_Id) + then + -- The dependence of a task unit on itself is implicit and + -- may or may not be explicitly specified (SPARK RM 6.1.4). + -- Emit an error if only one input/output is present. + + if Task_Input_Seen /= Task_Output_Seen then + Usage_Error (Item_Id); + end if; + -- States and global objects are not used properly only when -- the subprogram is subject to pragma Global. @@ -2036,20 +2108,18 @@ package body Sem_Prag is end if; -- A global item may denote a concurrent type as long as it is - -- the current instance of an enclosing concurrent type + -- the current instance of an enclosing protected or task type -- (SPARK RM 6.1.4). elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then - if Is_CCT_Instance (Item) then + if Is_CCT_Instance (Item_Id, Spec_Id) then -- Pragma [Refined_]Global associated with a protected -- subprogram cannot mention the current instance of a -- protected type because the instance behaves as a -- formal parameter. - if Ekind (Item_Id) = E_Protected_Type - and then Scope (Spec_Id) = Item_Id - then + if Ekind (Item_Id) = E_Protected_Type then Error_Msg_Name_1 := Chars (Item_Id); SPARK_Msg_NE (Fix_Msg (Spec_Id, "global item of subprogram & " @@ -2061,9 +2131,7 @@ package body Sem_Prag is -- cannot mention the current instance of a task type -- because the instance behaves as a formal parameter. - elsif Ekind (Item_Id) = E_Task_Type - and then Spec_Id = Item_Id - then + else pragma Assert (Ekind (Item_Id) = E_Task_Type); Error_Msg_Name_1 := Chars (Item_Id); SPARK_Msg_NE (Fix_Msg (Spec_Id, "global item of subprogram & " @@ -2081,6 +2149,39 @@ package body Sem_Prag is return; end if; + -- A global item may denote the anonymous object created for a + -- single protected/task type as long as the current instance + -- is the same single type (SPARK RM 6.1.4). + + elsif Is_Single_Concurrent_Object (Item_Id) + and then Is_CCT_Instance (Item_Id, Spec_Id) + then + -- Pragma [Refined_]Global associated with a protected + -- subprogram cannot mention the current instance of a + -- protected type because the instance behaves as a formal + -- parameter. + + if Is_Single_Protected_Object (Item_Id) then + Error_Msg_Name_1 := Chars (Item_Id); + SPARK_Msg_NE + (Fix_Msg (Spec_Id, "global item of subprogram & cannot " + & "reference current instance of protected type %"), + Item, Spec_Id); + return; + + -- Pragma [Refined_]Global associated with a task type + -- cannot mention the current instance of a task type + -- because the instance behaves as a formal parameter. + + else pragma Assert (Is_Single_Task_Object (Item_Id)); + Error_Msg_Name_1 := Chars (Item_Id); + SPARK_Msg_NE + (Fix_Msg (Spec_Id, "global item of subprogram & cannot " + & "reference current instance of task type %"), + Item, Spec_Id); + return; + end if; + -- A formal object may act as a global item inside a generic elsif Is_Formal_Object (Item_Id) then @@ -27455,23 +27556,55 @@ package body Sem_Prag is -- Is_CCT_Instance -- --------------------- - function Is_CCT_Instance (Ref : Node_Id) return Boolean is - Ref_Id : constant Entity_Id := Entity (Ref); - S : Entity_Id; + function Is_CCT_Instance + (Ref_Id : Entity_Id; + Context_Id : Entity_Id) return Boolean + is + S : Entity_Id; + Typ : Entity_Id; begin - -- Climb the scope chain looking for an enclosing concurrent type that - -- matches the referenced entity. + -- When the reference denotes a single protected type, the context is + -- either a protected subprogram or its body. - S := Current_Scope; - while Present (S) and then S /= Standard_Standard loop - if Ekind_In (S, E_Protected_Type, E_Task_Type) and then S = Ref_Id - then - return True; + if Is_Single_Protected_Object (Ref_Id) then + Typ := Scope (Context_Id); + + return + Ekind (Typ) = E_Protected_Type + and then Present (Anonymous_Object (Typ)) + and then Anonymous_Object (Typ) = Ref_Id; + + -- When the reference denotes a single task type, the context is either + -- the same type or if inside the body, the anonymous task type. + + elsif Is_Single_Task_Object (Ref_Id) then + if Ekind (Context_Id) = E_Task_Type then + return + Present (Anonymous_Object (Context_Id)) + and then Anonymous_Object (Context_Id) = Ref_Id; + else + return Ref_Id = Context_Id; end if; - S := Scope (S); - end loop; + -- Otherwise the reference denotes a protected or a task type. Climb the + -- scope chain looking for an enclosing concurrent type that matches the + -- referenced entity. + + else + pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type)); + + S := Current_Scope; + while Present (S) and then S /= Standard_Standard loop + if Ekind_In (S, E_Protected_Type, E_Task_Type) + and then S = Ref_Id + then + return True; + end if; + + S := Scope (S); + end loop; + end if; return False; end Is_CCT_Instance; diff --git a/gcc/ada/sigtramp-vxworks-vxsim.c b/gcc/ada/sigtramp-vxworks-vxsim.c deleted file mode 100644 index 918d9e5..0000000 --- a/gcc/ada/sigtramp-vxworks-vxsim.c +++ /dev/null @@ -1,141 +0,0 @@ -/**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * S I G T R A M P * - * * - * Asm Implementation File * - * * - * Copyright (C) 2011-2015, Free Software Foundation, Inc. * - * * - * GNAT is free software; you can redistribute it and/or modify it under * - * terms of the GNU General Public License as published by the Free Soft- * - * ware Foundation; either version 3, or (at your option) any later ver- * - * sion. GNAT is distributed in the hope that it will be useful, but WITH- * - * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. * - * * - * As a special exception under Section 7 of GPL version 3, you are granted * - * additional permissions described in the GCC Runtime Library Exception, * - * version 3.1, as published by the Free Software Foundation. * - * * - * In particular, you can freely distribute your programs built with the * - * GNAT Pro compiler, including any required library run-time units, using * - * any licensing terms of your choosing. See the AdaCore Software License * - * for full details. * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - -/******************************************************** - * VxWorks VXSIM version of the __gnat_sigtramp service * - ********************************************************/ - -#undef CPU -#define CPU __VXSIM_CPU__ - -#include "sigtramp.h" -/* See sigtramp.h for a general explanation of functionality. */ - -#include -#include -#ifndef __RTP__ -#include -#else -#include -#include - -typedef struct mcontext - { - REG_SET regs; - } mcontext_t; - -typedef struct ucontext - { - mcontext_t uc_mcontext; /* register set */ - struct ucontext * uc_link; /* not used */ - sigset_t uc_sigmask; /* set of signals blocked */ - stack_t uc_stack; /* stack of context signaled */ - } ucontext_t; -#endif - -/* ---------------------- - -- General comments -- - ---------------------- - - Stubs are generated from toplevel asms and .cfi directives, much simpler - to use and check for correctness than manual encodings of CFI byte - sequences. The general idea is to establish CFA as sigcontext->sc_pregs - (for DKM) and mcontext (for RTP) and state where to find the registers as - offsets from there. - - As of today, we support a stub providing CFI info for common - registers (GPRs, LR, ...). We might need variants with support for floating - point or altivec registers as well at some point. - - Checking which variant should apply and getting at sc_pregs / mcontext - is simpler to express in C (we can't use offsetof in toplevel asms and - hardcoding constants is not workable with the flurry of VxWorks variants), - so this is the choice for our toplevel interface. - - Note that the registers we "restore" here are those to which we have - direct access through the system sigcontext structure, which includes - only a partial set of the non-volatiles ABI-wise. */ - -/* ------------------------------------------- - -- Prototypes for our internal asm stubs -- - ------------------------------------------- - - Eventhough our symbols will remain local, the prototype claims "extern" - and not "static" to prevent compiler complaints about a symbol used but - never defined. */ - -/* sigtramp stub providing CFI info for common registers. */ - -extern void __gnat_sigtramp_vxsim_common -(int signo, void *siginfo, void *sigcontext, - __sigtramphandler_t * handler, void * sc_pregs); - - -/* ------------------------------------- - -- Common interface implementation -- - ------------------------------------- - - We enforce optimization to minimize the overhead of the extra layer. */ - -void __gnat_sigtramp_vxsim (int signo, void *si, void *sc, - __sigtramphandler_t * handler) - __attribute__((optimize(2))); - -void __gnat_sigtramp_vxsim (int signo, void *si, void *sc, - __sigtramphandler_t * handler) -{ -#ifdef __RTP__ - mcontext_t *mcontext = &((ucontext_t *) sc)->uc_mcontext; - - /* Pass MCONTEXT in the fifth position so that the assembly code can find - it at the same stack location or in the same register as SC_PREGS. */ - __gnat_sigtramp_vxsim_common (signo, si, mcontext, handler, mcontext); -#else - struct sigcontext * sctx = (struct sigcontext *) sc; - - __gnat_sigtramp_vxsim_common (signo, si, sctx, handler, sctx->sc_pregs); -#endif -} - -/* Include the target specific bits. */ -#include "sigtramp-vxworks-target.inc" - -/* sigtramp stub for common registers. */ - -#define TRAMP_COMMON __gnat_sigtramp_vxsim_common - -asm (SIGTRAMP_START(TRAMP_COMMON)); -asm (CFI_DEF_CFA); -asm (CFI_COMMON_REGS); -asm (SIGTRAMP_BODY); -asm (SIGTRAMP_END(TRAMP_COMMON)); - - diff --git a/gcc/ada/sigtramp-vxworks.c b/gcc/ada/sigtramp-vxworks.c index 360b921..e9dd9aa 100644 --- a/gcc/ada/sigtramp-vxworks.c +++ b/gcc/ada/sigtramp-vxworks.c @@ -89,12 +89,13 @@ typedef struct ucontext and not "static" to prevent compiler complaints about a symbol used but never defined. */ -/* sigtramp stub providing CFI info for common registers. */ +#define TRAMP_COMMON __gnat_sigtramp_common -extern void __gnat_sigtramp_common -(int signo, void *siginfo, void *sigcontext, - __sigtramphandler_t * handler, void * sc_pregs); +/* sigtramp stub providing CFI info for common registers. */ +extern void +TRAMP_COMMON (int signo, void *siginfo, void *sigcontext, + __sigtramphandler_t * handler, REG_SET * sc_pregs); /* ------------------------------------- -- Common interface implementation -- @@ -102,6 +103,14 @@ extern void __gnat_sigtramp_common We enforce optimization to minimize the overhead of the extra layer. */ +#if defined(__vxworks) && (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS) +static int __gnat_is_vxsim = 0; + +void __gnat_set_is_vxsim(int val) { + __gnat_is_vxsim = val; +} +#endif + void __gnat_sigtramp (int signo, void *si, void *sc, __sigtramphandler_t * handler) __attribute__((optimize(2))); @@ -109,17 +118,58 @@ void __gnat_sigtramp (int signo, void *si, void *sc, void __gnat_sigtramp (int signo, void *si, void *sc, __sigtramphandler_t * handler) { -#ifdef __RTP__ + REG_SET *pregs; + + /* VXSIM uses a different signal context structure than the regular x86 + targets: + * on x86-vx6: two 32-bit values are added at the end of the REG_SET, plus + an explicit padding of 0xc8 characters (200 characters). The sigcontext + containing a complete REG_SET just before the field 'sc_pregs', this + adds a 208 bytes offset to get the value of 'sc_pregs'. + * on x86-vx7: the same offset is used on vx7: 3 32-bit values are present + at the enf of the reg set, but the padding is then of 0xc4 characters. + * on x86_64-vx7: two 64-bit values are added at the beginning of the + REG_SET. This adds a 16 bytes offset to get the value of 'sc_pregs', + and another 16 bytes offset within the pregs structure to retrieve the + registers list. + */ + + /* Retrieve the registers to restore : */ +#ifndef __RTP__ +#ifdef __HANDLE_VXSIM_SC +#if defined(__i386__) + /* move sctx 208 bytes further, so that the vxsim's sc_pregs field coincide + with the expected x86 one */ + struct sigcontext * sctx = + (struct sigcontext *) (sc + (__gnat_is_vxsim ? 208 : 0)); +#elif defined(__x86_64__) + /* move sctx 16 bytes further, so that the vxsim's sc_pregs field coincide + with the expected x86_64 one */ + struct sigcontext * sctx = + (struct sigcontext *) (sc + (__gnat_is_vxsim ? 16 : 0)); +#endif /* __i386__ || __x86_64__ */ +#else /* __HANDLE_VXSIM_SC__ */ + struct sigcontext * sctx = (struct sigcontext *) sc; +#endif + + pregs = sctx->sc_pregs; + +#else /* !defined(__RTP__) */ + mcontext_t *mcontext = &((ucontext_t *) sc)->uc_mcontext; + /* No specific offset in this case for vxsim */ + pregs = &(mcontext->regs); - /* Pass MCONTEXT in the fifth position so that the assembly code can find - it at the same stack location or in the same register as SC_PREGS. */ - __gnat_sigtramp_common (signo, si, mcontext, handler, mcontext); -#else - struct sigcontext * sctx = (struct sigcontext *) sc; +#endif /* !defined(__RTP__) */ - __gnat_sigtramp_common (signo, si, sctx, handler, sctx->sc_pregs); +#if defined (__HANDLE_VXSIM_SC) && defined (__x86_64__) + /* Ignore the first two values, that are not registers in case of + vxsim */ + pregs = (REG_SET *) ((void *)pregs + (__gnat_is_vxsim ? 16 : 0)); #endif + + /* And now call the real signal trampoline with the list of registers */ + __gnat_sigtramp_common (signo, si, sc, handler, pregs); } /* Include the target specific bits. */ @@ -127,12 +177,8 @@ void __gnat_sigtramp (int signo, void *si, void *sc, /* sigtramp stub for common registers. */ -#define TRAMP_COMMON __gnat_sigtramp_common - asm (SIGTRAMP_START(TRAMP_COMMON)); asm (CFI_DEF_CFA); asm (CFI_COMMON_REGS); asm (SIGTRAMP_BODY); asm (SIGTRAMP_END(TRAMP_COMMON)); - - diff --git a/gcc/ada/sigtramp.h b/gcc/ada/sigtramp.h index 930365f..7314d6f 100644 --- a/gcc/ada/sigtramp.h +++ b/gcc/ada/sigtramp.h @@ -43,14 +43,15 @@ extern "C" { system headers so call it something unique. */ typedef void __sigtramphandler_t (int signo, void *siginfo, void *sigcontext); -#if defined(__vxworks) && (CPU == SIMNT || CPU == SIMPENTIUM || CPU == SIMLINUX) -/* Vxsim requires a specially compiled handler. */ -extern void __gnat_sigtramp_vxsim (int signo, void *siginfo, void *sigcontext, - __sigtramphandler_t * handler); -#else +/* The vxsim target has a different sigcontext structure than the one we're + compiling the run-time with. We thus need to adjust it in this case */ +#if defined(__vxworks) && (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS) +#define __HANDLE_VXSIM_SC +extern void __gnat_set_is_vxsim(int val); +#endif + extern void __gnat_sigtramp (int signo, void *siginfo, void *sigcontext, __sigtramphandler_t * handler); -#endif /* The signal trampoline is to be called from an established signal handler. It sets up the DWARF CFI and calls HANDLER (SIGNO, SIGINFO, SIGCONTEXT). -- 2.7.4