Skip to content

R
riscv-gcc-1
Commit 0d66b596 by Arnaud Charlet
Options

[multiple changes] 

2016-04-18  Ed Schonberg  <schonberg@adacore.com>

	* 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  <kirtchev@adacore.com>

	* 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  <kirtchev@adacore.com>

	* 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  <lambourg@adacore.com>

	* 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  <ebotcazou@adacore.com>

	* 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
parent a86c18d9
Showing with 448 additions and 332 deletions
gcc/ada/ChangeLog
2016-04-18 Ed Schonberg <schonberg@adacore.com>
* 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 <kirtchev@adacore.com>
* 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 <kirtchev@adacore.com>
* 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 <lambourg@adacore.com>
* 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 <ebotcazou@adacore.com>
* 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 <charlet@adacore.com> 2016-04-18 Arnaud Charlet <charlet@adacore.com>
* gnatvsn.ads (Library_Version): Bump to 7. * gnatvsn.ads (Library_Version): Bump to 7.
......
gcc/ada/exp_ch3.adb
...@@ -226,6 +226,9 @@ package body Exp_Ch3 is ...@@ -226,6 +226,9 @@ package body Exp_Ch3 is
-- --
-- The caller must append additional entries for discriminants if required. -- 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; function In_Runtime (E : Entity_Id) return Boolean;
-- Check if E is defined in the RTL (in a child of Ada or System). Used -- 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. -- to avoid to bring in the overhead of _Input, _Output for tagged types.
...@@ -756,14 +759,10 @@ package body Exp_Ch3 is ...@@ -756,14 +759,10 @@ package body Exp_Ch3 is
Set_Debug_Info_Off (Proc_Id); Set_Debug_Info_Off (Proc_Id);
end if; end if;
-- Set inlined unless tasks are around, in which case we do not -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
-- want to inline, because nested stuff may cause difficulties in -- component type itself (see also Build_Record_Init_Proc).
-- inter-unit inlining, and furthermore there is in any case no
-- point in inlining such complex init procs.
if not Has_Task (Proc_Id) then Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
Set_Is_Inlined (Proc_Id);
end if;
-- Associate Init_Proc with type, and determine if the procedure -- Associate Init_Proc with type, and determine if the procedure
-- is null (happens because of the Initialize_Scalars pragma case, -- is null (happens because of the Initialize_Scalars pragma case,
...@@ -3592,21 +3591,8 @@ package body Exp_Ch3 is ...@@ -3592,21 +3591,8 @@ package body Exp_Ch3 is
Build_Offset_To_Top_Functions; Build_Offset_To_Top_Functions;
Build_CPP_Init_Procedure; Build_CPP_Init_Procedure;
Build_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_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id); Set_Has_Completion (Proc_Id);
...@@ -3614,6 +3600,8 @@ package body Exp_Ch3 is ...@@ -3614,6 +3600,8 @@ package body Exp_Ch3 is
Set_Debug_Info_Off (Proc_Id); Set_Debug_Info_Off (Proc_Id);
end if; 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 -- Do not build an aggregate if Modify_Tree_For_C, this isn't
-- needed and may generate early references to non frozen types -- needed and may generate early references to non frozen types
-- since we expand aggregate much more systematically. -- since we expand aggregate much more systematically.
...@@ -8230,6 +8218,34 @@ package body Exp_Ch3 is ...@@ -8230,6 +8218,34 @@ package body Exp_Ch3 is
end if; end if;
end Has_New_Non_Standard_Rep; 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 -- -- In_Runtime --
---------------- ----------------
......
gcc/ada/freeze.adb
...@@ -1997,6 +1997,9 @@ package body Freeze is ...@@ -1997,6 +1997,9 @@ package body Freeze is
-- call, but rather must go in the package holding the function, so that -- call, but rather must go in the package holding the function, so that
-- the backend can process it in the proper context. -- 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); procedure Wrap_Imported_Subprogram (E : Entity_Id);
-- If E is an entity for an imported subprogram with pre/post-conditions -- 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- -- then this procedure will create a wrapper to ensure that proper run-
...@@ -4589,6 +4592,39 @@ package body Freeze is ...@@ -4589,6 +4592,39 @@ package body Freeze is
Append_List (Result, Decls); Append_List (Result, Decls);
end Late_Freeze_Subprogram; 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 -- -- Wrap_Imported_Subprogram --
------------------------------ ------------------------------
...@@ -6281,7 +6317,7 @@ package body Freeze is ...@@ -6281,7 +6317,7 @@ package body Freeze is
Set_Sloc (F_Node, Loc); Set_Sloc (F_Node, Loc);
else else
F_Node := New_Node (N_Freeze_Entity, Loc); F_Node := New_Freeze_Node;
Set_Freeze_Node (E, F_Node); Set_Freeze_Node (E, F_Node);
Set_Access_Types_To_Process (F_Node, No_Elist); Set_Access_Types_To_Process (F_Node, No_Elist);
Set_TSS_Elist (F_Node, No_Elist); Set_TSS_Elist (F_Node, No_Elist);
...@@ -6299,9 +6335,7 @@ package body Freeze is ...@@ -6299,9 +6335,7 @@ package body Freeze is
-- subtypes can only be elaborated after the type itself, and they -- subtypes can only be elaborated after the type itself, and they
-- need an itype reference. -- need an itype reference.
if Ekind (E) = E_Record_Type if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then
and then Has_Discriminants (E)
then
declare declare
Comp : Entity_Id; Comp : Entity_Id;
IR : Node_Id; IR : Node_Id;
......
gcc/ada/init-vxsim.c deleted 100644 → 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 *
* <http://www.gnu.org/licenses/>. *
* *
* 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 <signal.h>
#include <taskLib.h>
#ifndef __RTP__
#include <intLib.h>
#include <iv.h>
#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);
}
gcc/ada/init.c
...@@ -1705,10 +1705,12 @@ __gnat_install_handler (void) ...@@ -1705,10 +1705,12 @@ __gnat_install_handler (void)
#include <signal.h> #include <signal.h>
#include <taskLib.h> #include <taskLib.h>
#if defined (__i386__) && !defined (VTHREADS) #if (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
#include <sysLib.h> #include <sysLib.h>
#endif #endif
#include "sigtramp.h"
#ifndef __RTP__ #ifndef __RTP__
#include <intLib.h> #include <intLib.h>
#include <iv.h> #include <iv.h>
...@@ -1814,7 +1816,9 @@ __gnat_clear_exception_count (void) ...@@ -1814,7 +1816,9 @@ __gnat_clear_exception_count (void)
/* Handle different SIGnal to exception mappings in different VxWorks /* Handle different SIGnal to exception mappings in different VxWorks
versions. */ versions. */
void 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; struct Exception_Data *exception;
const char *msg; const char *msg;
...@@ -1924,14 +1928,6 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *sc) ...@@ -1924,14 +1928,6 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *sc)
Raise_From_Signal_Handler (exception, msg); 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) #if defined (ARMEL) && (_WRS_VXWORKS_MAJOR >= 7)
/* ARM-vx7 case with arm unwinding exceptions */ /* ARM-vx7 case with arm unwinding exceptions */
...@@ -2015,17 +2011,6 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) ...@@ -2015,17 +2011,6 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc)
__gnat_adjust_context_for_raise (sig, sc); __gnat_adjust_context_for_raise (sig, sc);
#endif #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, __gnat_sigtramp (sig, (void *)si, (void *)sc,
(__sigtramphandler_t *)&__gnat_map_signal); (__sigtramphandler_t *)&__gnat_map_signal);
...@@ -2057,7 +2042,6 @@ void ...@@ -2057,7 +2042,6 @@ void
__gnat_install_handler (void) __gnat_install_handler (void)
{ {
struct sigaction act; struct sigaction act;
char *model ATTRIBUTE_UNUSED;
/* Setup signal handler to map synchronous signals to appropriate /* Setup signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another exceptions. Make sure that the handler isn't interrupted by another
...@@ -2108,13 +2092,17 @@ __gnat_install_handler (void) ...@@ -2108,13 +2092,17 @@ __gnat_install_handler (void)
trap_0_entry->inst_fourth = 0xa1480000; trap_0_entry->inst_fourth = 0xa1480000;
#endif #endif
#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR != 7 #ifdef __HANDLE_VXSIM_SC
/* By experiment, found that sysModel () returns the following string /* By experiment, found that sysModel () returns the following string
prefix for vxsim when running on Linux and Windows. */ prefix for vxsim when running on Linux and Windows. */
model = sysModel (); {
char *model = sysModel ();
if ((strncmp (model, "Linux", 5) == 0) if ((strncmp (model, "Linux", 5) == 0)
|| (strncmp (model, "Windows", 7) == 0)) || (strncmp (model, "Windows", 7) == 0)
is_vxsim = 1; || (strncmp (model, "SIMLINUX", 8) == 0) /* vx7 */
|| (strncmp (model, "SIMWINDOWS", 10) == 0)) /* ditto */
__gnat_set_is_vxsim (TRUE);
}
#endif #endif
__gnat_handler_installed = 1; __gnat_handler_installed = 1;
......
gcc/ada/sem_disp.adb
...@@ -409,7 +409,7 @@ package body Sem_Disp is ...@@ -409,7 +409,7 @@ package body Sem_Disp is
-- fact direct. This routine detects the above case and modifies the -- fact direct. This routine detects the above case and modifies the
-- call accordingly. -- 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 -- If the call is tag-indeterminate and the entity being called is
-- abstract, verify that the context is a call that will eventually -- abstract, verify that the context is a call that will eventually
-- provide a tag for dispatching, or has provided one already. -- provide a tag for dispatching, or has provided one already.
...@@ -508,10 +508,9 @@ package body Sem_Disp is ...@@ -508,10 +508,9 @@ package body Sem_Disp is
-- Check_Dispatching_Context -- -- Check_Dispatching_Context --
------------------------------- -------------------------------
procedure Check_Dispatching_Context is procedure Check_Dispatching_Context (Call : Node_Id) is
Subp : constant Entity_Id := Entity (Name (N)); Subp : constant Entity_Id := Entity (Name (Call));
Typ : constant Entity_Id := Etype (Subp); Typ : constant Entity_Id := Etype (Subp);
Par : Node_Id;
procedure Abstract_Context_Error; procedure Abstract_Context_Error;
-- Error for abstract call dispatching on result is not dispatching -- Error for abstract call dispatching on result is not dispatching
...@@ -536,11 +535,15 @@ package body Sem_Disp is ...@@ -536,11 +535,15 @@ package body Sem_Disp is
end if; end if;
end Abstract_Context_Error; end Abstract_Context_Error;
-- Local variables
Par : Node_Id;
-- Start of processing for Check_Dispatching_Context -- Start of processing for Check_Dispatching_Context
begin begin
if Is_Abstract_Subprogram (Subp) if Is_Abstract_Subprogram (Subp)
and then No (Controlling_Argument (N)) and then No (Controlling_Argument (Call))
then then
if Present (Alias (Subp)) if Present (Alias (Subp))
and then not Is_Abstract_Subprogram (Alias (Subp)) and then not Is_Abstract_Subprogram (Alias (Subp))
...@@ -565,7 +568,8 @@ package body Sem_Disp is ...@@ -565,7 +568,8 @@ package body Sem_Disp is
-- but will be legal in overridings of the operation. -- but will be legal in overridings of the operation.
elsif In_Spec_Expression 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 and then
((Nkind (Parent (Current_Scope)) = N_Procedure_Specification ((Nkind (Parent (Current_Scope)) = N_Procedure_Specification
and then Null_Present (Parent (Current_Scope))) and then Null_Present (Parent (Current_Scope)))
...@@ -595,32 +599,54 @@ package body Sem_Disp is ...@@ -595,32 +599,54 @@ package body Sem_Disp is
return; return;
end if; end if;
Par := Parent (N); Par := Parent (Call);
if Nkind (Par) = N_Parameter_Association then if Nkind (Par) = N_Parameter_Association then
Par := Parent (Par); Par := Parent (Par);
end if; end if;
while Present (Par) loop if Nkind (Par) = N_Qualified_Expression
if Nkind_In (Par, N_Function_Call, or else Nkind (Par) = N_Unchecked_Type_Conversion
N_Procedure_Call_Statement) then
Par := Parent (Par);
end if;
if Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
and then Is_Entity_Name (Name (Par)) and then Is_Entity_Name (Name (Par))
then then
declare declare
Enc_Subp : constant Entity_Id := Entity (Name (Par)); Enc_Subp : constant Entity_Id := Entity (Name (Par));
A : Node_Id; A : Node_Id;
F : Entity_Id; F : Entity_Id;
Control : Entity_Id;
Ret_Type : Entity_Id;
begin begin
-- Find formal for which call is the actual, and is -- Find controlling formal that can provide tag for the
-- a controlling argument. -- tag-indeterminate actual. The corresponding actual
-- must be the corresponding class-wide type.
F := First_Formal (Enc_Subp); F := First_Formal (Enc_Subp);
A := First_Actual (Par); A := First_Actual (Par);
-- Find controlling type of call. Dereference if function
-- returns an access type.
Ret_Type := Etype (Call);
if Is_Access_Type (Etype (Call)) then
Ret_Type := Designated_Type (Ret_Type);
end if;
while Present (F) loop while Present (F) loop
Control := Etype (A);
if Is_Access_Type (Control) then
Control := Designated_Type (Control);
end if;
if Is_Controlling_Formal (F) if Is_Controlling_Formal (F)
and then (N = A or else Parent (N) = A) and then not (Call = A or else Parent (Call) = A)
and then Control = Class_Wide_Type (Ret_Type)
then then
return; return;
end if; end if;
...@@ -629,12 +655,23 @@ package body Sem_Disp is ...@@ -629,12 +655,23 @@ package body Sem_Disp is
Next_Actual (A); Next_Actual (A);
end loop; end loop;
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 Error_Msg_N
("call to abstract function must be dispatching", N); ("call to abstract function must be dispatching",
Call);
return; return;
end if;
end; end;
-- For equalitiy operators, one of the operands must be -- For equality operators, one of the operands must be
-- statically or dynamically tagged. -- statically or dynamically tagged.
elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then
...@@ -651,19 +688,14 @@ package body Sem_Disp is ...@@ -651,19 +688,14 @@ package body Sem_Disp is
return; return;
-- The left-hand side of an assignment provides the tag
elsif Nkind (Par) = N_Assignment_Statement then elsif Nkind (Par) = N_Assignment_Statement then
return; return;
elsif Nkind (Par) = N_Qualified_Expression
or else Nkind (Par) = N_Unchecked_Type_Conversion
then
Par := Parent (Par);
else else
Abstract_Context_Error; Abstract_Context_Error;
return;
end if; end if;
end loop;
end if; end if;
end if; end if;
end Check_Dispatching_Context; end Check_Dispatching_Context;
...@@ -813,11 +845,12 @@ package body Sem_Disp is ...@@ -813,11 +845,12 @@ package body Sem_Disp is
Next_Formal (Formal); Next_Formal (Formal);
end loop; 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 -- 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); Actual := First_Actual (N);
while Present (Actual) loop while Present (Actual) loop
...@@ -836,7 +869,7 @@ package body Sem_Disp is ...@@ -836,7 +869,7 @@ package body Sem_Disp is
then then
Func := Empty; Func := Empty;
-- Ditto if it is an explicit dereference. -- Ditto if it is an explicit dereference
elsif Nkind (Original_Node (Actual)) = N_Explicit_Dereference elsif Nkind (Original_Node (Actual)) = N_Explicit_Dereference
then then
...@@ -853,23 +886,36 @@ package body Sem_Disp is ...@@ -853,23 +886,36 @@ package body Sem_Disp is
if Present (Func) and then Is_Abstract_Subprogram (Func) then if Present (Func) and then Is_Abstract_Subprogram (Func) then
Error_Msg_N Error_Msg_N
("call to abstract function must be dispatching", N); ("call to abstract function must be dispatching",
Actual);
end if; end if;
end if; end if;
Next_Actual (Actual); Next_Actual (Actual);
end loop; 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; end if;
else else
-- If dispatching on result, the enclosing call, if any, will -- If dispatching on result, the enclosing call, if any, will
-- determine the controlling argument. Otherwise this is the -- determine the controlling argument. Otherwise this is the
-- primitive operation of the root type. -- primitive operation of the root type.
Check_Dispatching_Context; Check_Dispatching_Context (N);
end if; end if;
end Check_Dispatching_Call; end Check_Dispatching_Call;
......
gcc/ada/sem_prag.adb
...@@ -245,10 +245,13 @@ package body Sem_Prag is ...@@ -245,10 +245,13 @@ package body Sem_Prag is
-- Determine whether dependency clause Clause is surrounded by extra -- Determine whether dependency clause Clause is surrounded by extra
-- parentheses. If this is the case, issue an error message. -- 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_] -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
-- Global. Determine whether reference Ref denotes the current instance of -- Global. Determine whether entity Ref_Id denotes the current instance of
-- a concurrent type. -- a concurrent type. Context_Id denotes the associated context where the
-- pragma appears.
function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
-- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
...@@ -559,6 +562,10 @@ package body Sem_Prag is ...@@ -559,6 +562,10 @@ package body Sem_Prag is
-- Two lists containing the full set of inputs and output of the related -- Two lists containing the full set of inputs and output of the related
-- subprograms. Note that these lists contain both nodes and entities. -- 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); procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
-- Subsidiary routine to Check_Role and Check_Usage. Add the item kind -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
-- to the name buffer. The individual kinds are as follows: -- to the name buffer. The individual kinds are as follows:
...@@ -590,7 +597,7 @@ package body Sem_Prag is ...@@ -590,7 +597,7 @@ package body Sem_Prag is
Item_Id : Entity_Id; Item_Id : Entity_Id;
Is_Input : Boolean; Is_Input : Boolean;
Self_Ref : 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 -- 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 -- 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 -- attributes of an item. Flag Is_Input should be set when item comes
...@@ -763,10 +770,31 @@ package body Sem_Prag is ...@@ -763,10 +770,31 @@ package body Sem_Prag is
Null_Seen : in out Boolean; Null_Seen : in out Boolean;
Non_Null_Seen : in out Boolean) Non_Null_Seen : in out Boolean)
is 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; Is_Output : constant Boolean := not Is_Input;
Grouped : Node_Id; Grouped : Node_Id;
Item_Id : Entity_Id; Item_Id : Entity_Id;
-- Start of processing for Analyze_Input_Output
begin begin
-- Multiple input or output items appear as an aggregate -- Multiple input or output items appear as an aggregate
...@@ -899,18 +927,45 @@ package body Sem_Prag is ...@@ -899,18 +927,45 @@ package body Sem_Prag is
Ekind_In (Item_Id, E_Abstract_State, E_Variable) Ekind_In (Item_Id, E_Abstract_State, E_Variable)
then then
-- The item denotes a concurrent type, but it is not the -- The item denotes a concurrent type. Note that single
-- current instance of an enclosing concurrent type. -- 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) if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
and then not Is_CCT_Instance (Item)
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
-- 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 SPARK_Msg_N
("invalid use of subtype mark in dependency " ("invalid use of subtype mark in dependency "
& "relation", Item); & "relation", Item);
end if; end if;
-- Ensure that the item fulfils its role as input and/or -- 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
Current_Task_Instance_Seen;
end if;
-- Ensure that the item fulfills its role as input and/or
-- output as specified by pragma Global or the enclosing -- output as specified by pragma Global or the enclosing
-- context. -- context.
...@@ -1427,13 +1482,30 @@ package body Sem_Prag is ...@@ -1427,13 +1482,30 @@ package body Sem_Prag is
if Present (Item_Id) if Present (Item_Id)
and then not Contains (Used_Items, Item_Id) and then not Contains (Used_Items, Item_Id)
then then
-- The current instance of a concurrent type behaves as a if Is_Formal (Item_Id) then
-- formal parameter (SPARK RM 6.1.4). Usage_Error (Item_Id);
-- The current instance of a protected type behaves as a formal
-- parameter (SPARK RM 6.1.4).
if Is_Formal (Item_Id) elsif Ekind (Item_Id) = E_Protected_Type
or else Ekind_In (Item_Id, E_Protected_Type, E_Task_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 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); Usage_Error (Item_Id);
end if;
-- States and global objects are not used properly only when -- States and global objects are not used properly only when
-- the subprogram is subject to pragma Global. -- the subprogram is subject to pragma Global.
...@@ -2036,20 +2108,18 @@ package body Sem_Prag is ...@@ -2036,20 +2108,18 @@ package body Sem_Prag is
end if; end if;
-- A global item may denote a concurrent type as long as it is -- 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). -- (SPARK RM 6.1.4).
elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then 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 -- Pragma [Refined_]Global associated with a protected
-- subprogram cannot mention the current instance of a -- subprogram cannot mention the current instance of a
-- protected type because the instance behaves as a -- protected type because the instance behaves as a
-- formal parameter. -- formal parameter.
if Ekind (Item_Id) = E_Protected_Type if Ekind (Item_Id) = E_Protected_Type then
and then Scope (Spec_Id) = Item_Id
then
Error_Msg_Name_1 := Chars (Item_Id); Error_Msg_Name_1 := Chars (Item_Id);
SPARK_Msg_NE SPARK_Msg_NE
(Fix_Msg (Spec_Id, "global item of subprogram & " (Fix_Msg (Spec_Id, "global item of subprogram & "
...@@ -2061,9 +2131,7 @@ package body Sem_Prag is ...@@ -2061,9 +2131,7 @@ package body Sem_Prag is
-- cannot mention the current instance of a task type -- cannot mention the current instance of a task type
-- because the instance behaves as a formal parameter. -- because the instance behaves as a formal parameter.
elsif Ekind (Item_Id) = E_Task_Type else pragma Assert (Ekind (Item_Id) = E_Task_Type);
and then Spec_Id = Item_Id
then
Error_Msg_Name_1 := Chars (Item_Id); Error_Msg_Name_1 := Chars (Item_Id);
SPARK_Msg_NE SPARK_Msg_NE
(Fix_Msg (Spec_Id, "global item of subprogram & " (Fix_Msg (Spec_Id, "global item of subprogram & "
...@@ -2081,6 +2149,39 @@ package body Sem_Prag is ...@@ -2081,6 +2149,39 @@ package body Sem_Prag is
return; return;
end if; 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 -- A formal object may act as a global item inside a generic
elsif Is_Formal_Object (Item_Id) then elsif Is_Formal_Object (Item_Id) then
...@@ -27455,23 +27556,55 @@ package body Sem_Prag is ...@@ -27455,23 +27556,55 @@ package body Sem_Prag is
-- Is_CCT_Instance -- -- Is_CCT_Instance --
--------------------- ---------------------
function Is_CCT_Instance (Ref : Node_Id) return Boolean is function Is_CCT_Instance
Ref_Id : constant Entity_Id := Entity (Ref); (Ref_Id : Entity_Id;
Context_Id : Entity_Id) return Boolean
is
S : Entity_Id; S : Entity_Id;
Typ : Entity_Id;
begin begin
-- Climb the scope chain looking for an enclosing concurrent type that -- When the reference denotes a single protected type, the context is
-- matches the referenced entity. -- either a protected subprogram or its body.
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;
-- 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; S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop while Present (S) and then S /= Standard_Standard loop
if Ekind_In (S, E_Protected_Type, E_Task_Type) and then S = Ref_Id if Ekind_In (S, E_Protected_Type, E_Task_Type)
and then S = Ref_Id
then then
return True; return True;
end if; end if;
S := Scope (S); S := Scope (S);
end loop; end loop;
end if;
return False; return False;
end Is_CCT_Instance; end Is_CCT_Instance;
......
gcc/ada/sigtramp-vxworks-vxsim.c deleted 100644 → 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 <vxWorks.h>
#include <arch/../regs.h>
#ifndef __RTP__
#include <sigLib.h>
#else
#include <signal.h>
#include <regs.h>
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));
gcc/ada/sigtramp-vxworks.c
...@@ -89,12 +89,13 @@ typedef struct ucontext ...@@ -89,12 +89,13 @@ typedef struct ucontext
and not "static" to prevent compiler complaints about a symbol used but and not "static" to prevent compiler complaints about a symbol used but
never defined. */ never defined. */
/* sigtramp stub providing CFI info for common registers. */ #define TRAMP_COMMON __gnat_sigtramp_common
extern void __gnat_sigtramp_common /* sigtramp stub providing CFI info for common registers. */
(int signo, void *siginfo, void *sigcontext,
__sigtramphandler_t * handler, void * sc_pregs);
extern void
TRAMP_COMMON (int signo, void *siginfo, void *sigcontext,
__sigtramphandler_t * handler, REG_SET * sc_pregs);
/* ------------------------------------- /* -------------------------------------
-- Common interface implementation -- -- Common interface implementation --
...@@ -102,6 +103,14 @@ extern void __gnat_sigtramp_common ...@@ -102,6 +103,14 @@ extern void __gnat_sigtramp_common
We enforce optimization to minimize the overhead of the extra layer. */ 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, void __gnat_sigtramp (int signo, void *si, void *sc,
__sigtramphandler_t * handler) __sigtramphandler_t * handler)
__attribute__((optimize(2))); __attribute__((optimize(2)));
...@@ -109,17 +118,58 @@ void __gnat_sigtramp (int signo, void *si, void *sc, ...@@ -109,17 +118,58 @@ void __gnat_sigtramp (int signo, void *si, void *sc,
void __gnat_sigtramp (int signo, void *si, void *sc, void __gnat_sigtramp (int signo, void *si, void *sc,
__sigtramphandler_t * handler) __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; 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 #endif /* !defined(__RTP__) */
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;
__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 #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. */ /* Include the target specific bits. */
...@@ -127,12 +177,8 @@ void __gnat_sigtramp (int signo, void *si, void *sc, ...@@ -127,12 +177,8 @@ void __gnat_sigtramp (int signo, void *si, void *sc,
/* sigtramp stub for common registers. */ /* sigtramp stub for common registers. */
#define TRAMP_COMMON __gnat_sigtramp_common
asm (SIGTRAMP_START(TRAMP_COMMON)); asm (SIGTRAMP_START(TRAMP_COMMON));
asm (CFI_DEF_CFA); asm (CFI_DEF_CFA);
asm (CFI_COMMON_REGS); asm (CFI_COMMON_REGS);
asm (SIGTRAMP_BODY); asm (SIGTRAMP_BODY);
asm (SIGTRAMP_END(TRAMP_COMMON)); asm (SIGTRAMP_END(TRAMP_COMMON));
gcc/ada/sigtramp.h
...@@ -43,14 +43,15 @@ extern "C" { ...@@ -43,14 +43,15 @@ extern "C" {
system headers so call it something unique. */ system headers so call it something unique. */
typedef void __sigtramphandler_t (int signo, void *siginfo, void *sigcontext); typedef void __sigtramphandler_t (int signo, void *siginfo, void *sigcontext);
#if defined(__vxworks) && (CPU == SIMNT || CPU == SIMPENTIUM || CPU == SIMLINUX) /* The vxsim target has a different sigcontext structure than the one we're
/* Vxsim requires a specially compiled handler. */ compiling the run-time with. We thus need to adjust it in this case */
extern void __gnat_sigtramp_vxsim (int signo, void *siginfo, void *sigcontext, #if defined(__vxworks) && (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
__sigtramphandler_t * handler); #define __HANDLE_VXSIM_SC
#else extern void __gnat_set_is_vxsim(int val);
#endif
extern void __gnat_sigtramp (int signo, void *siginfo, void *sigcontext, extern void __gnat_sigtramp (int signo, void *siginfo, void *sigcontext,
__sigtramphandler_t * handler); __sigtramphandler_t * handler);
#endif
/* The signal trampoline is to be called from an established signal handler. /* The signal trampoline is to be called from an established signal handler.
It sets up the DWARF CFI and calls HANDLER (SIGNO, SIGINFO, SIGCONTEXT). It sets up the DWARF CFI and calls HANDLER (SIGNO, SIGINFO, SIGCONTEXT).
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment