+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>
* gnatvsn.ads (Library_Version): Bump to 7.
--
-- 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.
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,
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);
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.
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 --
----------------
-- 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-
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 --
------------------------------
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);
-- 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;
+++ /dev/null
-/****************************************************************************
- * *
- * 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);
-}
#include <signal.h>
#include <taskLib.h>
-#if defined (__i386__) && !defined (VTHREADS)
+#if (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
#include <sysLib.h>
#endif
+#include "sigtramp.h"
+
#ifndef __RTP__
#include <intLib.h>
#include <iv.h>
/* 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;
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 */
__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);
__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
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;
-- 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.
-- 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
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))
-- 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)))
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;
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
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
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;
-- 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
-- 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:
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
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
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.
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.
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 & "
-- 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 & "
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
-- 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;
+++ /dev/null
-/****************************************************************************
- * *
- * 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));
-
-
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 --
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)));
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. */
/* 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));
-
-
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).
projects / gcc.git / commitdiff