procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2014-08-04  Yannick Moy  <moy@adacore.com>

	* sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode,
	do not generate two Itypes with the same name for an array
	definition.
	* sinfo.ads: Expand doc on GNATprove mode.

2014-08-04  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch3.adb (Expand_Freeze_Record_Type): Set the finalization
	master and storage pool attributes on the root type of an
	anonymous access type.
	* exp_ch4.adb (Expand_N_Allocator): Set the finalization master
	and storage pool attributes on the root type of an anonymous
	access type.

2014-08-04  Arnaud Charlet  <charlet@adacore.com>

	* exp_ch3.adb: Minor reformatting.
	* tb-alvms.c, tb-alvxw.c, tb-ivms.c: Removed.
	* tracebak.c: Remove use of above files.
	* gcc-interface/Makefile.in: Update dependencies.

2014-08-04  Pierre-Marie Derodat  <derodat@adacore.com>

	* gcc-interface/utils.c (gnat_set_type_context): Also set the
	context for parallel types' TYPE_STUB_DECL.  Do not change
	anything if the context is already set for them.
	(gnat_pushdecl): Update the comment for calls to
	gnat_set_type_context to mention parallel types.
	(add_parallel_type): When adding a context-less parallel type to
	a type that has a context, propagate the context from the latter
	type to the former.
	(process_deferred_decl_context): Call gnat_set_type_context
	rather than manually setting the type context.
	(build_unc_object_type): Call gnat_set_type_context on the
	template type.

From-SVN: r213584
This commit is contained in:
Arnaud Charlet 2014-08-04 15:02:44 +02:00
parent 69fff50e08
commit 24d4b3d500
11 changed files with 190 additions and 1542 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

38
gcc/ada/ChangeLog
View file

@ -1,3 +1,41 @@
2014-08-04 Yannick Moy <moy@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode,
do not generate two Itypes with the same name for an array
definition.
* sinfo.ads: Expand doc on GNATprove mode.
2014-08-04 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb (Expand_Freeze_Record_Type): Set the finalization
master and storage pool attributes on the root type of an
anonymous access type.
* exp_ch4.adb (Expand_N_Allocator): Set the finalization master
and storage pool attributes on the root type of an anonymous
access type.
2014-08-04 Arnaud Charlet <charlet@adacore.com>
* exp_ch3.adb: Minor reformatting.
* tb-alvms.c, tb-alvxw.c, tb-ivms.c: Removed.
* tracebak.c: Remove use of above files.
* gcc-interface/Makefile.in: Update dependencies.
2014-08-04 Pierre-Marie Derodat <derodat@adacore.com>
* gcc-interface/utils.c (gnat_set_type_context): Also set the
context for parallel types' TYPE_STUB_DECL. Do not change
anything if the context is already set for them.
(gnat_pushdecl): Update the comment for calls to
gnat_set_type_context to mention parallel types.
(add_parallel_type): When adding a context-less parallel type to
a type that has a context, propagate the context from the latter
type to the former.
(process_deferred_decl_context): Call gnat_set_type_context
rather than manually setting the type context.
(build_unc_object_type): Call gnat_set_type_context on the
template type.
2014-08-04 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_N_Case_Statement): If a choice is a

172
gcc/ada/exp_ch3.adb
View file

@ -7235,35 +7235,39 @@ package body Exp_Ch3 is
Master_Built := True;
-- All anonymous access-to-controlled types allocate
-- on the global pool.
-- on the global pool. Note that the finalization
-- master and the associated storage pool must be set
-- on the root type (both are "root type only").
Set_Associated_Storage_Pool
(Comp_Typ, RTE (RE_Global_Pool_Object));
(Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
Build_Finalization_Master
(Typ => Comp_Typ,
(Typ => Root_Type (Comp_Typ),
Ins_Node => Ins_Node,
Encl_Scope => Encl_Scope);
Fin_Mas_Id := Finalization_Master (Comp_Typ);
-- Subsequent anonymous access-to-controlled components
-- reuse the already available master.
-- reuse the available master.
else
-- All anonymous access-to-controlled types allocate
-- on the global pool.
-- on the global pool. Note that both the finalization
-- master and the associated storage pool must be set
-- on the root type (both are "root type only").
Set_Associated_Storage_Pool
(Comp_Typ, RTE (RE_Global_Pool_Object));
(Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-- Shared the master among multiple components
Set_Finalization_Master (Comp_Typ, Fin_Mas_Id);
Set_Finalization_Master
(Root_Type (Comp_Typ), Fin_Mas_Id);
-- Convert the master into a heterogeneous collection.
-- Generate:
--
-- Set_Is_Heterogeneous (<Fin_Mas_Id>);
if not Attributes_Set then
@ -7271,7 +7275,7 @@ package body Exp_Ch3 is
Insert_Action (Ins_Node,
Make_Procedure_Call_Statement (Loc,
Name =>
Name =>
New_Occurrence_Of
(RTE (RE_Set_Is_Heterogeneous), Loc),
Parameter_Associations => New_List (
@ -7330,9 +7334,7 @@ package body Exp_Ch3 is
-- Primitive operations of tagged types are frozen when the dispatch
-- table is constructed.
if not Comes_From_Source (Typ)
or else Is_Tagged_Type (Typ)
then
if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
return;
end if;
@ -7342,7 +7344,7 @@ package body Exp_Ch3 is
if Present (Stream_Op)
and then Is_Subprogram (Stream_Op)
and then Nkind (Unit_Declaration_Node (Stream_Op)) =
N_Subprogram_Declaration
N_Subprogram_Declaration
and then not Is_Frozen (Stream_Op)
then
Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
@ -7371,9 +7373,9 @@ package body Exp_Ch3 is
if Present (Access_Types_To_Process (N)) then
declare
E : Elmt_Id := First_Elmt (Access_Types_To_Process (N));
begin
while Present (E) loop
if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
Validate_RACW_Primitives (Node (E));
RACW_Seen := True;
@ -7395,7 +7397,6 @@ package body Exp_Ch3 is
if Is_Record_Type (Def_Id) then
if Ekind (Def_Id) = E_Record_Type then
Expand_Freeze_Record_Type (N);
elsif Is_Class_Wide_Type (Def_Id) then
Expand_Freeze_Class_Wide_Type (N);
end if;
@ -7460,21 +7461,18 @@ package body Exp_Ch3 is
if Is_Composite_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
then
DT_Size :=
Make_Integer_Literal (Loc, 0);
DT_Align :=
Make_Integer_Literal (Loc, Maximum_Alignment);
DT_Size := Make_Integer_Literal (Loc, 0);
DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
else
DT_Size :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Desig_Type, Loc),
Prefix => New_Occurrence_Of (Desig_Type, Loc),
Attribute_Name => Name_Max_Size_In_Storage_Elements);
DT_Align :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Desig_Type, Loc),
Prefix => New_Occurrence_Of (Desig_Type, Loc),
Attribute_Name => Name_Alignment);
end if;
@ -7508,26 +7506,26 @@ package body Exp_Ch3 is
Append_Freeze_Action (Freeze_Action_Typ,
Make_Object_Declaration (Loc,
Defining_Identifier => Pool_Object,
Object_Definition =>
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(RTE (RE_Stack_Bounded_Pool), Loc),
Constraint =>
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
-- First discriminant is the Pool Size
-- First discriminant is the Pool Size
New_Occurrence_Of (
Storage_Size_Variable (Def_Id), Loc),
-- Second discriminant is the element size
-- Second discriminant is the element size
DT_Size,
-- Third discriminant is the alignment
-- Third discriminant is the alignment
DT_Align)))));
end;
@ -7575,8 +7573,8 @@ package body Exp_Ch3 is
if Is_Ancestor (RSPWS, Etype (Pool)) then
Error_Msg_N
("??subpool access type has deeper accessibility " &
"level than pool", Def_Id);
("??subpool access type has deeper accessibility "
& "level than pool", Def_Id);
Append_Freeze_Action (Def_Id,
Make_Raise_Program_Error (Loc,
@ -7593,10 +7591,9 @@ package body Exp_Ch3 is
elsif Is_Class_Wide_Type (Etype (Pool)) then
Append_Freeze_Action (Def_Id,
Make_If_Statement (Loc,
Condition =>
Condition =>
Make_In (Loc,
Left_Opnd =>
New_Occurrence_Of (Pool, Loc),
Left_Opnd => New_Occurrence_Of (Pool, Loc),
Right_Opnd =>
New_Occurrence_Of
(Class_Wide_Type (RSPWS), Loc)),
@ -8016,7 +8013,7 @@ package body Exp_Ch3 is
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Choices => New_List (
Make_Others_Choice (Loc)),
Expression =>
Get_Simple_Init_Val
@ -8112,17 +8109,16 @@ package body Exp_Ch3 is
-- other checks.
declare
Bod : Node_Id;
Bod : Node_Id;
Inv_Id : constant Entity_Id := Invariant_Procedure (Typ);
Call : constant Node_Id :=
Call : constant Node_Id :=
Make_Procedure_Call_Statement (Sloc (N),
Name => New_Occurrence_Of (Proc_Id, Loc),
Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations =>
New_List
(New_Occurrence_Of (First_Formal (Inv_Id), Loc)));
begin
-- The invariant body has not been analyzed yet, so we do a
-- sequential search forward, and retrieve it by name.
@ -8229,11 +8225,10 @@ package body Exp_Ch3 is
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uInit),
In_Present => True,
Out_Present => True,
Parameter_Type => New_Occurrence_Of (Typ, Loc)));
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
In_Present => True,
Out_Present => True,
Parameter_Type => New_Occurrence_Of (Typ, Loc)));
-- For task record value, or type that contains tasks, add two more
-- formals, _Master : Master_Id and _Chain : in out Activation_Chain
@ -8324,9 +8319,9 @@ package body Exp_Ch3 is
if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
Expression =>
New_Occurrence_Of (Iface_Tag, Loc)));
@ -8362,8 +8357,8 @@ package body Exp_Ch3 is
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of
(RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
Name =>
New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
@ -8398,11 +8393,12 @@ package body Exp_Ch3 is
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of
(Offset_To_Top_Comp, Loc)),
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
@ -8424,7 +8420,7 @@ package body Exp_Ch3 is
Offset_Value =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
@ -8443,8 +8439,9 @@ package body Exp_Ch3 is
if RTE_Available (RE_Register_Interface_Offset) then
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of
(RTE (RE_Register_Interface_Offset), Loc),
Name =>
New_Occurrence_Of
(RTE (RE_Register_Interface_Offset), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
@ -8456,14 +8453,13 @@ package body Exp_Ch3 is
New_Occurrence_Of (Standard_True, Loc),
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Occurrence_Of (Tag_Comp, Loc)),
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Occurrence_Of (Tag_Comp, Loc)),
Attribute_Name => Name_Position)),
Make_Null (Loc))));
@ -8537,8 +8533,8 @@ package body Exp_Ch3 is
then
exit when
(Is_Record_Type (Comp_Typ)
and then Is_Variable_Size_Record
(Base_Type (Comp_Typ)))
and then
Is_Variable_Size_Record (Base_Type (Comp_Typ)))
or else
(Is_Array_Type (Comp_Typ)
and then Is_Variable_Size_Array (Comp_Typ));
@ -8551,7 +8547,7 @@ package body Exp_Ch3 is
Error_Msg_Node_2 := Comp;
Error_Msg_NE
("parent type & with dynamic component & cannot be parent"
& " of 'C'P'P derivation if new interfaces are present",
& " of 'C'P'P derivation if new interfaces are present",
Typ, Scope (Original_Record_Component (Comp)));
Error_Msg_Sloc :=
@ -8760,16 +8756,17 @@ package body Exp_Ch3 is
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Extension_Aggregate (Loc,
Ancestor_Part =>
Ancestor_Part =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Alias (Subp), Loc),
Name =>
New_Occurrence_Of (Alias (Subp), Loc),
Parameter_Associations => Actual_List),
Null_Record_Present => True));
Func_Body :=
Make_Subprogram_Body (Loc,
Specification => New_Copy_Tree (Func_Spec),
Declarations => Empty_List,
Specification => New_Copy_Tree (Func_Spec),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Return_Stmt)));
@ -9223,7 +9220,7 @@ package body Exp_Ch3 is
Expression =>
Make_Op_Not (Loc,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Target, Loc),
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Chars (Left_Op)),
Make_Identifier (Loc, Chars (Right_Op)))))));
@ -9287,15 +9284,14 @@ package body Exp_Ch3 is
-- of the interface type)
if Is_Controlling_Formal (Formal) then
if Nkind (Parameter_Type (Parent (Formal)))
= N_Identifier
if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
then
Set_Parameter_Type (New_Param_Spec,
New_Occurrence_Of (Tag_Typ, Loc));
else pragma Assert
(Nkind (Parameter_Type (Parent (Formal)))
= N_Access_Definition);
(Nkind (Parameter_Type (Parent (Formal))) =
N_Access_Definition);
Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
New_Occurrence_Of (Tag_Typ, Loc));
end if;
@ -9310,10 +9306,10 @@ package body Exp_Ch3 is
Append_To (Decl_List,
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Subp)),
Parameter_Specifications => Formal_List,
Null_Present => True)));
Null_Present => True)));
end if;
Next_Elmt (Prim_Elmt);
@ -9352,7 +9348,7 @@ package body Exp_Ch3 is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
Eq_Name : Name_Id := Name_Op_Eq;
Eq_Name : Name_Id := Name_Op_Eq;
Eq_Needed : Boolean;
Eq_Spec : Node_Id;
Prim : Elmt_Id;
@ -9482,11 +9478,12 @@ package body Exp_Ch3 is
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Y),
Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
Ret_Type => Standard_Boolean);
Append_To (Res, Eq_Spec);
@ -9588,9 +9585,8 @@ package body Exp_Ch3 is
Specification =>
Make_Disp_Timed_Select_Spec (Tag_Typ)));
-- If the ancestor is an interface type we declare non-abstract
-- primitives to override the abstract primitives of the interface
-- type.
-- If ancestor is an interface type, declare non-abstract primitives
-- to override the abstract primitives of the interface type.
-- In VM targets we define these primitives in all root tagged types
-- that are not interface types. Done because in VM targets we don't
@ -9675,8 +9671,7 @@ package body Exp_Ch3 is
Consider_IS : Boolean := True) return Boolean
is
Consider_IS_NS : constant Boolean :=
Normalize_Scalars
or (Initialize_Scalars and Consider_IS);
Normalize_Scalars or (Initialize_Scalars and Consider_IS);
begin
-- Never need initialization if it is suppressed
@ -9691,7 +9686,6 @@ package body Exp_Ch3 is
if Is_Private_Type (T) then
declare
RT : constant Entity_Id := Underlying_Type (T);
begin
if Present (RT) then
return Needs_Simple_Initialization (RT);
@ -10014,8 +10008,7 @@ package body Exp_Ch3 is
if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
and then No (TSS (Tag_Typ, TSS_Stream_Output))
then
Build_Record_Or_Elementary_Output_Procedure
(Loc, Tag_Typ, Decl, Ent);
Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
@ -10063,9 +10056,8 @@ package body Exp_Ch3 is
Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
end if;
if not Is_Limited_Type (Tag_Typ)
and then not Is_Interface (Tag_Typ)
then
if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
-- Body for equality
if Eq_Needed then
@ -10126,6 +10118,7 @@ package body Exp_Ch3 is
Make_Adjust_Call (
Obj_Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ))));
else
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
@ -10145,6 +10138,7 @@ package body Exp_Ch3 is
Make_Final_Call
(Obj_Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ))));
else
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,

22
gcc/ada/exp_ch4.adb
View file

@ -1124,10 +1124,11 @@ package body Exp_Ch4 is
-- Inherit the allocation-related attributes from the original
-- access type.
Set_Finalization_Master (Def_Id, Finalization_Master (PtrT));
Set_Finalization_Master
(Def_Id, Finalization_Master (PtrT));
Set_Associated_Storage_Pool (Def_Id,
Associated_Storage_Pool (PtrT));
Set_Associated_Storage_Pool
(Def_Id, Associated_Storage_Pool (PtrT));
-- Declare the object using the previous type declaration
@ -4318,26 +4319,29 @@ package body Exp_Ch4 is
-- Anonymous access-to-controlled types allocate on the global pool.
-- Do not set this attribute on .NET/JVM since those targets do not
-- support pools.
-- support pools. Note that this is a "root type only" attribute.
if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then
if Present (Rel_Typ) then
Set_Associated_Storage_Pool
(PtrT, Associated_Storage_Pool (Rel_Typ));
(Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
else
Set_Associated_Storage_Pool
(PtrT, RTE (RE_Global_Pool_Object));
(Root_Type (PtrT), RTE (RE_Global_Pool_Object));
end if;
end if;
-- The finalization master must be inserted and analyzed as part of
-- the current semantic unit. Note that the master is updated when
-- analysis changes current units.
-- analysis changes current units. Note that this is a "root type
-- only" attribute.
if Present (Rel_Typ) then
Set_Finalization_Master (PtrT, Finalization_Master (Rel_Typ));
Set_Finalization_Master
(Root_Type (PtrT), Finalization_Master (Rel_Typ));
else
Set_Finalization_Master (PtrT, Current_Anonymous_Master);
Set_Finalization_Master
(Root_Type (PtrT), Current_Anonymous_Master);
end if;
end if;

4
gcc/ada/gcc-interface/Makefile.in
View file

@ -515,7 +515,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(target_cpu) $(target_vendor) $(target
endif
# PowerPC and e500v2 VxWorks
ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $(target_os))),)
ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_vendor) $(target_os))),)
ifeq ($(strip $(filter-out e500%, $(target_alias))),)
ARCH_STR=e500
@ -3012,7 +3012,7 @@ a-tags.o : a-tags.adb a-tags.ads
# need to keep the frame pointer in this file to pop the stack properly on
# some targets.
tracebak.o : tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c
tracebak.o : tracebak.c tb-gcc.c
$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \
$(INCLUDES) -fno-omit-frame-pointer $< $(OUTPUT_OPTION)

45
gcc/ada/gcc-interface/utils.c
View file

@ -575,7 +575,18 @@ gnat_set_type_context (tree type, tree context)
while (decl && DECL_PARALLEL_TYPE (decl))
{
TYPE_CONTEXT (DECL_PARALLEL_TYPE (decl)) = context;
tree parallel_type = DECL_PARALLEL_TYPE (decl);
/* Give a context to the parallel types and their stub decl, if any.
Some parallel types seems to be present in multiple parallel type
chains, so don't mess with their context if they already have one. */
if (TYPE_CONTEXT (parallel_type) == NULL_TREE)
{
if (TYPE_STUB_DECL (parallel_type) != NULL_TREE)
DECL_CONTEXT (TYPE_STUB_DECL (parallel_type)) = context;
TYPE_CONTEXT (parallel_type) = context;
}
decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl));
}
}
@ -799,7 +810,9 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
t = NULL_TREE;
/* Propagate the name to all the anonymous variants. This is needed
for the type qualifiers machinery to work properly. */
for the type qualifiers machinery to work properly. Also propagate
the context to them. Note that the context will be propagated to all
parallel types too thanks to gnat_set_type_context. */
if (t)
for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
@ -1763,7 +1776,10 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
rest_of_record_type_compilation (record_type);
}
/* Append PARALLEL_TYPE on the chain of parallel types of TYPE. */
/* Append PARALLEL_TYPE on the chain of parallel types of TYPE. If
PARRALEL_TYPE has no context and its computation is not deferred yet, also
propagate TYPE's context to PARALLEL_TYPE's or defer its propagation to the
moment TYPE will get a context. */
void
add_parallel_type (tree type, tree parallel_type)
@ -1774,6 +1790,19 @@ add_parallel_type (tree type, tree parallel_type)
decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl));
SET_DECL_PARALLEL_TYPE (decl, parallel_type);
/* If PARALLEL_TYPE already has a context, we are done. */
if (TYPE_CONTEXT (parallel_type) != NULL_TREE)
return;
/* Otherwise, try to get one from TYPE's context. */
if (TYPE_CONTEXT (type) != NULL_TREE)
/* TYPE already has a context, so simply propagate it to PARALLEL_TYPE. */
gnat_set_type_context (parallel_type, TYPE_CONTEXT (type));
/* ... otherwise TYPE has not context yet. We know it will thanks to
gnat_pushdecl, and then its context will be propagated to PARALLEL_TYPE.
So we have nothing to do in this case. */
}
/* Return true if TYPE has a parallel type. */
@ -2851,7 +2880,7 @@ process_deferred_decl_context (bool force)
..._TYPE nodes. */
FOR_EACH_VEC_ELT (node->types, i, t)
{
TYPE_CONTEXT (t) = context;
gnat_set_type_context (t, context);
}
processed = true;
}
@ -3629,6 +3658,7 @@ tree
build_unc_object_type (tree template_type, tree object_type, tree name,
bool debug_info_p)
{
tree decl;
tree type = make_node (RECORD_TYPE);
tree template_field
= create_field_decl (get_identifier ("BOUNDS"), template_type, type,
@ -3644,7 +3674,12 @@ build_unc_object_type (tree template_type, tree object_type, tree name,
/* Declare it now since it will never be declared otherwise. This is
necessary to ensure that its subtrees are properly marked. */
create_type_decl (name, type, true, debug_info_p, Empty);
decl = create_type_decl (name, type, true, debug_info_p, Empty);
/* template_type will not be used elsewhere than here, so to keep the debug
info clean and in order to avoid scoping issues, make decl its
context. */
gnat_set_type_context (template_type, decl);
return type;
}

8
gcc/ada/sem_ch3.adb
View file

@ -3769,6 +3769,14 @@ package body Sem_Ch3 is
elsif Is_Interface (T) then
null;
-- In GNATprove mode, Expand_Subtype_From_Expr does nothing. Thus,
-- we should prevent the generation of another Itype with the
-- same name as the one already generated, or we end up with
-- two identical types in GNATprove.
elsif GNATprove_Mode then
null;
else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);

4
gcc/ada/sinfo.ads
View file

@ -577,6 +577,10 @@ package Sinfo is
-- warning issued when generating code, to avoid formal verification
-- of a partial unit.
-- 4. Unconstrained types are not replaced by constrained types whose
-- bounds are generated from an expression: Expand_Subtype_From_Expr
-- should be noop.
-----------------------
-- Check Flag Fields --
-----------------------

395
gcc/ada/tb-alvms.c
View file

@ -1,395 +0,0 @@
/****************************************************************************
* *
* GNAT RUN-TIME COMPONENTS *
* *
* T R A C E B A C K - A l p h a / V M S *
* *
* C Implementation File *
* *
* Copyright (C) 2003-2011, AdaCore *
* *
* 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. *
* *
****************************************************************************/
/* Alpha VMS requires a special treatment due to the complexity of the ABI.
What is here is along the lines of what the MD_FALLBACK_FRAME_STATE_FOR
macro does for frame unwinding during exception propagation. This file is
#included within tracebak.c in the appropriate case.
Most of the contents is directed by the OpenVMS/Alpha Conventions (ABI)
document, sections of which we will refer to as ABI-<section_number>. */
#include <vms/pdscdef.h>
#include <vms/libicb.h>
#include <vms/chfctxdef.h>
#include <vms/chfdef.h>
/* A couple of items missing from the header file included above. */
extern void * SYS$GL_CALL_HANDL;
#define PDSC$M_BASE_FRAME (1 << 10)
/* Registers are 64bit wide and addresses are 32bit wide on alpha-vms. */
typedef void * ADDR;
typedef unsigned long long REG;
#define REG_AT(addr) (*(REG *)(addr))
#define AS_REG(addr) ((REG)(unsigned long)(addr))
#define AS_ADDR(reg) ((ADDR)(unsigned long)(reg))
#define ADDR_IN(reg) (AS_ADDR(reg))
/* The following structure defines the state maintained during the
unwinding process. */
typedef struct
{
ADDR pc; /* Address of the call insn involved in the chain. */
ADDR sp; /* Stack Pointer at the time of this call. */
ADDR fp; /* Frame Pointer at the time of this call. */
/* The values above are fetched as saved REGisters on the stack. They are
typed ADDR because this is what the values in those registers are. */
/* Values of the registers saved by the functions in the chain,
incrementally updated through consecutive calls to the "unwind" function
below. */
REG saved_regs [32];
} frame_state_t;
/* Shortcuts for saved_regs of specific interest:
Frame Pointer is r29,
Stack Pointer is r30,
Return Address is r26,
Procedure Value is r27.
This is from ABI-3.1.1 [Integer Registers]. */
#define saved_fpr saved_regs[29]
#define saved_spr saved_regs[30]
#define saved_rar saved_regs[26]
#define saved_pvr saved_regs[27]
/* Special values for saved_rar, used to control the overall unwinding
process. */
#define RA_UNKNOWN ((REG)~0)
#define RA_STOP ((REG)0)
/* We still use a number of macros similar to the ones for the generic
__gnat_backtrace implementation. */
#define PC_ADJUST 4
#define STOP_FRAME (frame_state.saved_rar == RA_STOP)
/* Compute Procedure Value from Frame Pointer value. This follows the rules
in ABI-3.6.1 [Current Procedure]. */
#define PV_FOR(FP) \
(((FP) != 0) \
? (((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP)) : 0)
/**********
* unwind *
**********/
/* Helper for __gnat_backtrace.
FS represents some call frame, identified by a pc and associated frame
pointer in FS->pc and FS->fp. FS->saved_regs contains the state of the
general registers upon entry in this frame. Of most interest in this set
are the saved return address and frame pointer registers, which actually
allow identifying the caller's frame.
This routine "unwinds" the input frame state by adjusting it to eventually
represent its caller's frame. The basic principle is to shift the fp and pc
saved values into the current state, and then compute the corresponding new
saved registers set.
If the call chain goes through a signal handler, special processing is
required when we process the kernel frame which has called the handler, to
switch it to the interrupted context frame. */
#define K_HANDLER_FRAME(fs) (PV_FOR ((fs)->fp) == SYS$GL_CALL_HANDL)
static void unwind_regular_code (frame_state_t * fs);
static void unwind_kernel_handler (frame_state_t * fs);
void
unwind (frame_state_t * fs)
{
/* Don't do anything if requested so. */
if (fs->saved_rar == RA_STOP)
return;
/* Retrieve the values of interest computed during the previous
call. PC_ADJUST gets us from the return address to the call insn
address. */
fs->pc = ADDR_IN (fs->saved_rar) - PC_ADJUST;
fs->sp = ADDR_IN (fs->saved_spr);
fs->fp = ADDR_IN (fs->saved_fpr);
/* Unless we are able to determine otherwise, set the frame state's
saved return address such that the unwinding process will stop. */
fs->saved_rar = RA_STOP;
/* Now we want to update fs->saved_regs to reflect the state of the caller
of the procedure described by pc/fp.
The condition to check for a special kernel frame which has called a
signal handler is stated in ABI-6.7.1 [Signaler's Registers] : "The frame
of the call to the handler can be identified by the return address of
SYS$CALL_HANDL+4". We use the equivalent procedure value identification
here because SYS$CALL_HANDL appears to be undefined. */
if (K_HANDLER_FRAME (fs))
unwind_kernel_handler (fs);
else
unwind_regular_code (fs);
}
/***********************
* unwind_regular_code *
***********************/
/* Helper for unwind, for the case of unwinding through regular code which
is not a signal handler. */
static void
unwind_regular_code (frame_state_t * fs)
{
PDSCDEF * pv = PV_FOR (fs->fp);
ADDR frame_base;
/* Use the procedure value to unwind, in a way depending on the kind of
procedure at hand. See ABI-3.3 [Procedure Representation] and ABI-3.4
[Procedure Types]. */
if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
return;
frame_base
= (pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp;
switch (pv->pdsc$w_flags & 0xf)
{
case PDSC$K_KIND_FP_STACK:
/* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers
from the Register Save Area in the frame. */
{
ADDR rsa_base = frame_base + pv->pdsc$w_rsa_offset;
int i, j;
fs->saved_rar = REG_AT (rsa_base);
fs->saved_pvr = REG_AT (frame_base);
for (i = 0, j = 0; i < 32; i++)
if (pv->pdsc$l_ireg_mask & (1 << i))
fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j);
/* Note that the loop above is guaranteed to set fs->saved_fpr,
because "The preserved register set must always include R29(FP)
since it will always be used." (ABI-3.4.3.4 [Register Save Area for
All Stack Frames]).
Also note that we need to run through all the registers to ensure
that unwinding through register procedures (see below) gets the
right values out of the saved_regs array. */
}
break;
case PDSC$K_KIND_FP_REGISTER:
/* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from
the registers where they have been saved. */
{
fs->saved_rar = fs->saved_regs[pv->pdsc$b_save_ra];
fs->saved_fpr = fs->saved_regs[pv->pdsc$b_save_fp];
}
break;
default:
/* ??? Are we supposed to ever get here ? Don't think so. */
break;
}
/* SP is actually never part of the saved registers area, so we use the
corresponding entry in the saved_regs array to manually keep track of
it's evolution. */
fs->saved_spr = AS_REG (frame_base) + pv->pdsc$l_size;
}
/*************************
* unwind_kernel_handler *
*************************/
/* Helper for unwind, for the specific case of unwinding through a signal
handler.
The input frame state describes the kernel frame which has called a signal
handler. We fill the corresponding saved_regs to have it's "caller" frame
represented as the interrupted context. */
static void
unwind_kernel_handler (frame_state_t * fs)
{
PDSCDEF * pv = PV_FOR (fs->fp);
CHFDEF1 *sigargs;
CHFDEF2 *mechargs;
/* Retrieve the arguments passed to the handler, by way of a VMS service
providing the corresponding "Invocation Context Block". */
{
long handler_ivhandle;
INVO_CONTEXT_BLK handler_ivcb;
CHFCTX *chfctx;
handler_ivcb.libicb$q_ireg [29] = AS_REG (fs->fp);
handler_ivcb.libicb$q_ireg [30] = 0;
handler_ivhandle = LIB$GET_INVO_HANDLE (&handler_ivcb);
if ((LIB$GET_INVO_CONTEXT (handler_ivhandle, &handler_ivcb) & 1) != 1)
return;
chfctx = (CHFCTX *) AS_ADDR (handler_ivcb.libicb$ph_chfctx_addr);
sigargs = (CHFDEF1 *) AS_ADDR (chfctx->chfctx$q_sigarglst);
mechargs = (CHFDEF2 *) AS_ADDR (chfctx->chfctx$q_mcharglst);
}
/* Compute the saved return address as the PC of the instruction causing the
condition, accounting for the fact that it will be adjusted by the next
call to "unwind" as if it was an actual call return address. */
{
/* ABI-6.5.1.1 [Signal Argument Vector]: The signal occurrence address
is available from the sigargs argument to the handler, designed to
support both 32 and 64 bit addresses. The initial reference we get
is a pointer to the 32bit form, from which one may extract a pointer
to the 64bit version if need be. We work directly from the 32bit
form here. */
/* The sigargs vector structure for 32bits addresses is:
<......32bit......>
+-----------------+
| Vsize | :chf$is_sig_args
+-----------------+ -+-
| Condition Value | : [0]
+-----------------+ :
| ... | :
+-----------------+ : vector of Vsize entries
| Signal PC | :
+-----------------+ :
| PS | : [Vsize - 1]
+-----------------+ -+-
*/
unsigned long * sigargs_vector
= ((unsigned long *) (&sigargs->chf$is_sig_args)) + 1;
long sigargs_vsize
= sigargs->chf$is_sig_args;
fs->saved_rar = (REG) sigargs_vector [sigargs_vsize - 2] + PC_ADJUST;
}
fs->saved_spr = RA_UNKNOWN;
fs->saved_fpr = (REG) mechargs->chf$q_mch_frame;
fs->saved_pvr = (REG) mechargs->chf$q_mch_savr27;
fs->saved_regs[16] = (REG) mechargs->chf$q_mch_savr16;
fs->saved_regs[17] = (REG) mechargs->chf$q_mch_savr17;
fs->saved_regs[18] = (REG) mechargs->chf$q_mch_savr18;
fs->saved_regs[19] = (REG) mechargs->chf$q_mch_savr19;
fs->saved_regs[20] = (REG) mechargs->chf$q_mch_savr20;
}
/* Structure representing a traceback entry in the tracebacks array to be
filled by __gnat_backtrace below.
!! This should match what is in System.Traceback_Entries, so beware of
!! the REG/ADDR difference here.
The use of a structure is motivated by the potential necessity of having
several fields to fill for each entry, for instance if later calls to VMS
system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */
typedef struct {
ADDR pc; /* Program Counter. */
ADDR pv; /* Procedure Value. */
} tb_entry_t;
/********************
* __gnat_backtrace *
********************/
int
__gnat_backtrace (void **array, int size,
void *exclude_min, void *exclude_max, int skip_frames)
{
int cnt;
tb_entry_t * tbe = (tb_entry_t *)&array [0];
frame_state_t frame_state;
/* Setup the frame state before initiating the unwinding sequence. */
register REG this_FP __asm__("$29");
register REG this_SP __asm__("$30");
frame_state.saved_fpr = this_FP;
frame_state.saved_spr = this_SP;
frame_state.saved_rar = RA_UNKNOWN;
unwind (&frame_state);
/* At this point frame_state describes this very function. Skip the
requested number of calls. */
for (cnt = 0; cnt < skip_frames; cnt ++)
unwind (&frame_state);
/* Now consider each frame as a potential candidate for insertion inside
the provided array. */
cnt = 0;
while (cnt < size)
{
/* Stop if either the frame contents or the unwinder say so. */
if (STOP_FRAME)
break;
if (! K_HANDLER_FRAME (&frame_state)
&& (frame_state.pc < exclude_min || frame_state.pc > exclude_max))
{
tbe->pc = (ADDR) frame_state.pc;
tbe->pv = (ADDR) PV_FOR (frame_state.fp);
cnt ++;
tbe ++;
}
unwind (&frame_state);
}
return cnt;
}

940
gcc/ada/tb-alvxw.c
View file

@ -1,940 +0,0 @@
/****************************************************************************
* *
* GNAT RUN-TIME COMPONENTS *
* *
* T R A C E B A C K - A l p h a / V x W o r k s *
* *
* C Implementation File *
* *
* Copyright (C) 2000-2011, AdaCore *
* *
* 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. *
* *
****************************************************************************/
/* Alpha vxWorks requires a special, complex treatment that is extracted
from GDB. This file is #included within tracebak.c in the appropriate
case. */
#include <stddef.h>
#include <stdlib.h>
#include <limits.h>
#include <string.h>
extern void kerTaskEntry(void);
/* We still use a number of macros similar to the ones for the generic
__gnat_backtrace implementation. */
#define SKIP_FRAME 1
#define PC_ADJUST -4
#define STOP_FRAME \
(current == NULL \
|| ((CORE_ADDR) &kerTaskEntry >= PROC_LOW_ADDR (current->proc_desc) \
&& current->pc >= (CORE_ADDR) &kerTaskEntry))
/* Register numbers of various important registers.
Note that most of these values are "real" register numbers,
and correspond to the general registers of the machine,
and FP_REGNUM is a "phony" register number which is too large
to be an actual register number as far as the user is concerned
but serves to get the desired value when passed to read_register. */
#define T7_REGNUM 8 /* Return address register for OSF/1 __add* */
#define GCC_FP_REGNUM 15 /* Used by gcc as frame register */
#define T9_REGNUM 23 /* Return address register for OSF/1 __div* */
#define SP_REGNUM 30 /* Contains address of top of stack */
#define RA_REGNUM 26 /* Contains return address value */
#define FP0_REGNUM 32 /* Floating point register 0 */
#define PC_REGNUM 64 /* Contains program counter */
#define NUM_REGS 66
#define VM_MIN_ADDRESS (CORE_ADDR)0x120000000
#define SIZEOF_FRAME_SAVED_REGS (sizeof (CORE_ADDR) * (NUM_REGS))
#define INIT_EXTRA_FRAME_INFO(fromleaf, fci) init_extra_frame_info(fci)
#define FRAME_CHAIN(thisframe) (CORE_ADDR) alpha_frame_chain (thisframe)
#define FRAME_CHAIN_VALID(CHAIN, THISFRAME) \
((CHAIN) != 0 \
&& !inside_entry_file (FRAME_SAVED_PC (THISFRAME)))
#define FRAME_SAVED_PC(FRAME) (alpha_frame_saved_pc (FRAME))
#define FRAME_CHAIN_COMBINE(CHAIN, THISFRAME) (CHAIN)
#define INIT_FRAME_PC(FROMLEAF, PREV)
#define INIT_FRAME_PC_FIRST(FROMLEAF, PREV) \
(PREV)->pc = ((FROMLEAF) ? SAVED_PC_AFTER_CALL ((PREV)->next) \
: (PREV)->next ? FRAME_SAVED_PC ((PREV)->next) : read_pc ());
#define SAVED_PC_AFTER_CALL(FRAME) alpha_saved_pc_after_call (FRAME)
typedef unsigned long long int bfd_vma;
typedef bfd_vma CORE_ADDR;
typedef struct pdr
{
bfd_vma adr; /* memory address of start of procedure */
long isym; /* start of local symbol entries */
long iline; /* start of line number entries*/
long regmask; /* save register mask */
long regoffset; /* save register offset */
long iopt; /* start of optimization symbol entries*/
long fregmask; /* save floating point register mask */
long fregoffset; /* save floating point register offset */
long frameoffset; /* frame size */
short framereg; /* frame pointer register */
short pcreg; /* offset or reg of return pc */
long lnLow; /* lowest line in the procedure */
long lnHigh; /* highest line in the procedure */
bfd_vma cbLineOffset; /* byte offset for this procedure from the fd base */
/* These fields are new for 64 bit ECOFF. */
unsigned gp_prologue : 8; /* byte size of GP prologue */
unsigned gp_used : 1; /* true if the procedure uses GP */
unsigned reg_frame : 1; /* true if register frame procedure */
unsigned prof : 1; /* true if compiled with -pg */
unsigned reserved : 13; /* reserved: must be zero */
unsigned localoff : 8; /* offset of local variables from vfp */
} PDR;
typedef struct alpha_extra_func_info
{
long numargs; /* number of args to procedure (was iopt) */
PDR pdr; /* Procedure descriptor record */
}
*alpha_extra_func_info_t;
struct frame_info
{
/* Nominal address of the frame described. See comments at FRAME_FP
about what this means outside the *FRAME* macros; in the *FRAME*
macros, it can mean whatever makes most sense for this machine. */
CORE_ADDR frame;
/* Address at which execution is occurring in this frame. For the
innermost frame, it's the current pc. For other frames, it is a
pc saved in the next frame. */
CORE_ADDR pc;
/* For each register, address of where it was saved on entry to the
frame, or zero if it was not saved on entry to this frame. This
includes special registers such as pc and fp saved in special
ways in the stack frame. The SP_REGNUM is even more special, the
address here is the sp for the next frame, not the address where
the sp was saved. Allocated by frame_saved_regs_zalloc () which
is called and initialized by FRAME_INIT_SAVED_REGS. */
CORE_ADDR *saved_regs; /*NUM_REGS */
int localoff;
int pc_reg;
alpha_extra_func_info_t proc_desc;
/* Pointers to the next and previous frame_info's in the frame cache. */
struct frame_info *next, *prev;
};
struct frame_saved_regs
{
/* For each register R (except the SP), regs[R] is the address at
which it was saved on entry to the frame, or zero if it was not
saved on entry to this frame. This includes special registers
such as pc and fp saved in special ways in the stack frame.
regs[SP_REGNUM] is different. It holds the actual SP, not the
address at which it was saved. */
CORE_ADDR regs[NUM_REGS];
};
static CORE_ADDR theRegisters[32];
/* Prototypes for local functions. */
static CORE_ADDR read_next_frame_reg (struct frame_info *, int);
static CORE_ADDR heuristic_proc_start (CORE_ADDR);
static int alpha_about_to_return (CORE_ADDR pc);
static void init_extra_frame_info (struct frame_info *);
static CORE_ADDR alpha_frame_chain (struct frame_info *);
static CORE_ADDR alpha_frame_saved_pc (struct frame_info *frame);
static void *trace_alloc (unsigned int);
static struct frame_info *create_new_frame (CORE_ADDR, CORE_ADDR);
static alpha_extra_func_info_t
heuristic_proc_desc (CORE_ADDR, CORE_ADDR, struct frame_info *,
struct frame_saved_regs *);
static alpha_extra_func_info_t
find_proc_desc (CORE_ADDR, struct frame_info *, struct frame_saved_regs *);
/* Heuristic_proc_start may hunt through the text section for a long
time across a 2400 baud serial line. Allows the user to limit this
search. */
static unsigned int heuristic_fence_post = 1<<16;
/* Layout of a stack frame on the alpha:
| |
pdr members: | 7th ... nth arg, |
| `pushed' by caller. |
| |
----------------|-------------------------------|<-- old_sp == vfp
^ ^ ^ ^ | |
| | | | | |
| |localoff | Copies of 1st .. 6th |
| | | | | argument if necessary. |
| | | v | |
| | | --- |-------------------------------|<-- FRAME_LOCALS_ADDRESS
| | | | |
| | | | Locals and temporaries. |
| | | | |
| | | |-------------------------------|
| | | | |
|-fregoffset | Saved float registers. |
| | | | F9 |
| | | | . |
| | | | . |
| | | | F2 |
| | v | |
| | -------|-------------------------------|
| | | |
| | | Saved registers. |
| | | S6 |
|-regoffset | . |
| | | . |
| | | S0 |
| | | pdr.pcreg |
| v | |
| ----------|-------------------------------|
| | |
frameoffset | Argument build area, gets |
| | 7th ... nth arg for any |
| | called procedure. |
v | |
-------------|-------------------------------|<-- sp
| | */
#define PROC_LOW_ADDR(PROC) ((PROC)->pdr.adr) /* least address */
#define PROC_HIGH_ADDR(PROC) ((PROC)->pdr.iline) /* upper address bound */
#define PROC_DUMMY_FRAME(PROC) ((PROC)->pdr.cbLineOffset) /*CALL_DUMMY frame */
#define PROC_FRAME_OFFSET(PROC) ((PROC)->pdr.frameoffset)
#define PROC_FRAME_REG(PROC) ((PROC)->pdr.framereg)
#define PROC_REG_MASK(PROC) ((PROC)->pdr.regmask)
#define PROC_FREG_MASK(PROC) ((PROC)->pdr.fregmask)
#define PROC_REG_OFFSET(PROC) ((PROC)->pdr.regoffset)
#define PROC_FREG_OFFSET(PROC) ((PROC)->pdr.fregoffset)
#define PROC_PC_REG(PROC) ((PROC)->pdr.pcreg)
#define PROC_LOCALOFF(PROC) ((PROC)->pdr.localoff)
/* Local storage allocation/deallocation functions. trace_alloc does
a malloc, but also chains allocated blocks on trace_alloc_chain, so
they may all be freed on exit from __gnat_backtrace. */
struct alloc_chain
{
struct alloc_chain *next;
double x[0];
};
struct alloc_chain *trace_alloc_chain;
static void *
trace_alloc (unsigned int n)
{
struct alloc_chain * result = malloc (n + sizeof(struct alloc_chain));
result->next = trace_alloc_chain;
trace_alloc_chain = result;
return (void*) result->x;
}
static void
free_trace_alloc (void)
{
while (trace_alloc_chain != 0)
{
struct alloc_chain *old = trace_alloc_chain;
trace_alloc_chain = trace_alloc_chain->next;
free (old);
}
}
/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
otherwise. */
static int
read_memory_safe4 (CORE_ADDR addr, unsigned int *dest)
{
*dest = *((unsigned int*) addr);
return 0;
}
/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
otherwise. */
static int
read_memory_safe8 (CORE_ADDR addr, CORE_ADDR *dest)
{
*dest = *((CORE_ADDR*) addr);
return 0;
}
static CORE_ADDR
read_register (int regno)
{
if (regno >= 0 && regno < 31)
return theRegisters[regno];
return (CORE_ADDR) 0;
}
static void
frame_saved_regs_zalloc (struct frame_info *fi)
{
fi->saved_regs = (CORE_ADDR *) trace_alloc (SIZEOF_FRAME_SAVED_REGS);
memset (fi->saved_regs, 0, SIZEOF_FRAME_SAVED_REGS);
}
static void *
frame_obstack_alloc (unsigned long size)
{
return (void *) trace_alloc (size);
}
static int
inside_entry_file (CORE_ADDR addr)
{
if (addr == 0)
return 1;
else
return 0;
}
static CORE_ADDR
alpha_saved_pc_after_call (struct frame_info *frame)
{
CORE_ADDR pc = frame->pc;
alpha_extra_func_info_t proc_desc;
int pcreg;
proc_desc = find_proc_desc (pc, frame->next, NULL);
pcreg = proc_desc ? PROC_PC_REG (proc_desc) : RA_REGNUM;
return read_register (pcreg);
}
/* Guaranteed to set frame->saved_regs to some values (it never leaves it
NULL). */
static void
alpha_find_saved_regs (struct frame_info *frame)
{
int ireg;
CORE_ADDR reg_position;
unsigned long mask;
alpha_extra_func_info_t proc_desc;
int returnreg;
frame_saved_regs_zalloc (frame);
/* If it is the frame for __sigtramp, the saved registers are located in a
sigcontext structure somewhere on the stack. __sigtramp passes a pointer
to the sigcontext structure on the stack. If the stack layout for
__sigtramp changes, or if sigcontext offsets change, we might have to
update this code. */
#ifndef SIGFRAME_PC_OFF
#define SIGFRAME_PC_OFF (2 * 8)
#define SIGFRAME_REGSAVE_OFF (4 * 8)
#define SIGFRAME_FPREGSAVE_OFF (SIGFRAME_REGSAVE_OFF + 32 * 8 + 8)
#endif
proc_desc = frame->proc_desc;
if (proc_desc == NULL)
/* I'm not sure how/whether this can happen. Normally when we can't
find a proc_desc, we "synthesize" one using heuristic_proc_desc
and set the saved_regs right away. */
return;
/* Fill in the offsets for the registers which gen_mask says
were saved. */
reg_position = frame->frame + PROC_REG_OFFSET (proc_desc);
mask = PROC_REG_MASK (proc_desc);
returnreg = PROC_PC_REG (proc_desc);
/* Note that RA is always saved first, regardless of its actual
register number. */
if (mask & (1 << returnreg))
{
frame->saved_regs[returnreg] = reg_position;
reg_position += 8;
mask &= ~(1 << returnreg); /* Clear bit for RA so we
don't save again later. */
}
for (ireg = 0; ireg <= 31; ireg++)
if (mask & (1 << ireg))
{
frame->saved_regs[ireg] = reg_position;
reg_position += 8;
}
/* Fill in the offsets for the registers which float_mask says
were saved. */
reg_position = frame->frame + PROC_FREG_OFFSET (proc_desc);
mask = PROC_FREG_MASK (proc_desc);
for (ireg = 0; ireg <= 31; ireg++)
if (mask & (1 << ireg))
{
frame->saved_regs[FP0_REGNUM + ireg] = reg_position;
reg_position += 8;
}
frame->saved_regs[PC_REGNUM] = frame->saved_regs[returnreg];
}
static CORE_ADDR
read_next_frame_reg (struct frame_info *fi, int regno)
{
CORE_ADDR result;
for (; fi; fi = fi->next)
{
/* We have to get the saved sp from the sigcontext
if it is a signal handler frame. */
if (regno == SP_REGNUM)
return fi->frame;
else
{
if (fi->saved_regs == 0)
alpha_find_saved_regs (fi);
if (fi->saved_regs[regno])
{
if (read_memory_safe8 (fi->saved_regs[regno], &result) == 0)
return result;
else
return 0;
}
}
}
return read_register (regno);
}
static CORE_ADDR
alpha_frame_saved_pc (struct frame_info *frame)
{
return read_next_frame_reg (frame, frame->pc_reg);
}
static struct alpha_extra_func_info temp_proc_desc;
/* Nonzero if instruction at PC is a return instruction. "ret
$zero,($ra),1" on alpha. */
static int
alpha_about_to_return (CORE_ADDR pc)
{
int inst;
read_memory_safe4 (pc, &inst);
return inst == 0x6bfa8001;
}
/* A heuristically computed start address for the subprogram
containing address PC. Returns 0 if none detected. */
static CORE_ADDR
heuristic_proc_start (CORE_ADDR pc)
{
CORE_ADDR start_pc = pc;
CORE_ADDR fence = start_pc - heuristic_fence_post;
if (start_pc == 0)
return 0;
if (heuristic_fence_post == UINT_MAX
|| fence < VM_MIN_ADDRESS)
fence = VM_MIN_ADDRESS;
/* search back for previous return */
for (start_pc -= 4; ; start_pc -= 4)
{
if (start_pc < fence)
return 0;
else if (alpha_about_to_return (start_pc))
break;
}
start_pc += 4; /* skip return */
return start_pc;
}
static alpha_extra_func_info_t
heuristic_proc_desc (CORE_ADDR start_pc,
CORE_ADDR limit_pc,
struct frame_info *next_frame,
struct frame_saved_regs *saved_regs_p)
{
CORE_ADDR sp = read_next_frame_reg (next_frame, SP_REGNUM);
CORE_ADDR cur_pc;
int frame_size;
int has_frame_reg = 0;
unsigned long reg_mask = 0;
int pcreg = -1;
if (start_pc == 0)
return 0;
memset (&temp_proc_desc, '\0', sizeof (temp_proc_desc));
if (saved_regs_p != 0)
memset (saved_regs_p, '\0', sizeof (struct frame_saved_regs));
PROC_LOW_ADDR (&temp_proc_desc) = start_pc;
if (start_pc + 200 < limit_pc)
limit_pc = start_pc + 200;
frame_size = 0;
for (cur_pc = start_pc; cur_pc < limit_pc; cur_pc += 4)
{
unsigned int word;
int status;
status = read_memory_safe4 (cur_pc, &word);
if (status)
return 0;
if ((word & 0xffff0000) == 0x23de0000) /* lda $sp,n($sp) */
{
if (word & 0x8000)
frame_size += (-word) & 0xffff;
else
/* Exit loop if a positive stack adjustment is found, which
usually means that the stack cleanup code in the function
epilogue is reached. */
break;
}
else if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
&& (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
{
int reg = (word & 0x03e00000) >> 21;
reg_mask |= 1 << reg;
if (saved_regs_p != 0)
saved_regs_p->regs[reg] = sp + (short) word;
/* Starting with OSF/1-3.2C, the system libraries are shipped
without local symbols, but they still contain procedure
descriptors without a symbol reference. GDB is currently
unable to find these procedure descriptors and uses
heuristic_proc_desc instead.
As some low level compiler support routines (__div*, __add*)
use a non-standard return address register, we have to
add some heuristics to determine the return address register,
or stepping over these routines will fail.
Usually the return address register is the first register
saved on the stack, but assembler optimization might
rearrange the register saves.
So we recognize only a few registers (t7, t9, ra) within
the procedure prologue as valid return address registers.
If we encounter a return instruction, we extract the
return address register from it.
FIXME: Rewriting GDB to access the procedure descriptors,
e.g. via the minimal symbol table, might obviate this hack. */
if (pcreg == -1
&& cur_pc < (start_pc + 80)
&& (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM))
pcreg = reg;
}
else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
pcreg = (word >> 16) & 0x1f;
else if (word == 0x47de040f) /* bis sp,sp fp */
has_frame_reg = 1;
}
if (pcreg == -1)
{
/* If we haven't found a valid return address register yet,
keep searching in the procedure prologue. */
while (cur_pc < (limit_pc + 80) && cur_pc < (start_pc + 80))
{
unsigned int word;
if (read_memory_safe4 (cur_pc, &word))
break;
cur_pc += 4;
if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
&& (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
{
int reg = (word & 0x03e00000) >> 21;
if (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM)
{
pcreg = reg;
break;
}
}
else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
{
pcreg = (word >> 16) & 0x1f;
break;
}
}
}
if (has_frame_reg)
PROC_FRAME_REG (&temp_proc_desc) = GCC_FP_REGNUM;
else
PROC_FRAME_REG (&temp_proc_desc) = SP_REGNUM;
PROC_FRAME_OFFSET (&temp_proc_desc) = frame_size;
PROC_REG_MASK (&temp_proc_desc) = reg_mask;
PROC_PC_REG (&temp_proc_desc) = (pcreg == -1) ? RA_REGNUM : pcreg;
PROC_LOCALOFF (&temp_proc_desc) = 0; /* XXX - bogus */
return &temp_proc_desc;
}
static alpha_extra_func_info_t
find_proc_desc (CORE_ADDR pc,
struct frame_info *next_frame,
struct frame_saved_regs *saved_regs)
{
CORE_ADDR startaddr;
/* If heuristic_fence_post is nonzero, determine the procedure
start address by examining the instructions.
This allows us to find the start address of static functions which
have no symbolic information, as startaddr would have been set to
the preceding global function start address by the
find_pc_partial_function call above. */
startaddr = heuristic_proc_start (pc);
return heuristic_proc_desc (startaddr, pc, next_frame, saved_regs);
}
static CORE_ADDR
alpha_frame_chain (struct frame_info *frame)
{
alpha_extra_func_info_t proc_desc;
CORE_ADDR saved_pc = FRAME_SAVED_PC (frame);
if (saved_pc == 0 || inside_entry_file (saved_pc))
return 0;
proc_desc = find_proc_desc (saved_pc, frame, NULL);
if (!proc_desc)
return 0;
/* If no frame pointer and frame size is zero, we must be at end
of stack (or otherwise hosed). If we don't check frame size,
we loop forever if we see a zero size frame. */
if (PROC_FRAME_REG (proc_desc) == SP_REGNUM
&& PROC_FRAME_OFFSET (proc_desc) == 0)
return 0;
else
return read_next_frame_reg (frame, PROC_FRAME_REG (proc_desc))
+ PROC_FRAME_OFFSET (proc_desc);
}
static void
init_extra_frame_info (struct frame_info *frame)
{
struct frame_saved_regs temp_saved_regs;
alpha_extra_func_info_t proc_desc =
find_proc_desc (frame->pc, frame->next, &temp_saved_regs);
frame->saved_regs = NULL;
frame->localoff = 0;
frame->pc_reg = RA_REGNUM;
frame->proc_desc = proc_desc;
if (proc_desc)
{
/* Get the locals offset and the saved pc register from the
procedure descriptor, they are valid even if we are in the
middle of the prologue. */
frame->localoff = PROC_LOCALOFF (proc_desc);
frame->pc_reg = PROC_PC_REG (proc_desc);
/* Fixup frame-pointer - only needed for top frame */
/* This may not be quite right, if proc has a real frame register.
Get the value of the frame relative sp, procedure might have been
interrupted by a signal at it's very start. */
if (frame->pc == PROC_LOW_ADDR (proc_desc))
frame->frame = read_next_frame_reg (frame->next, SP_REGNUM);
else
frame->frame
= (read_next_frame_reg (frame->next, PROC_FRAME_REG (proc_desc))
+ PROC_FRAME_OFFSET (proc_desc));
frame->saved_regs
= (CORE_ADDR *) frame_obstack_alloc (SIZEOF_FRAME_SAVED_REGS);
memcpy
(frame->saved_regs, temp_saved_regs.regs, SIZEOF_FRAME_SAVED_REGS);
frame->saved_regs[PC_REGNUM] = frame->saved_regs[RA_REGNUM];
}
}
/* Create an arbitrary (i.e. address specified by user) or innermost frame.
Always returns a non-NULL value. */
static struct frame_info *
create_new_frame (CORE_ADDR addr, CORE_ADDR pc)
{
struct frame_info *fi;
fi = (struct frame_info *)
trace_alloc (sizeof (struct frame_info));
/* Arbitrary frame */
fi->next = NULL;
fi->prev = NULL;
fi->frame = addr;
fi->pc = pc;
#ifdef INIT_EXTRA_FRAME_INFO
INIT_EXTRA_FRAME_INFO (0, fi);
#endif
return fi;
}
static CORE_ADDR current_pc;
static void
set_current_pc (void)
{
current_pc = (CORE_ADDR) __builtin_return_address (0);
}
static CORE_ADDR
read_pc (void)
{
return current_pc;
}
static struct frame_info *
get_current_frame (void)
{
return create_new_frame (0, read_pc ());
}
/* Return the frame that called FI.
If FI is the original frame (it has no caller), return 0. */
static struct frame_info *
get_prev_frame (struct frame_info *next_frame)
{
CORE_ADDR address = 0;
struct frame_info *prev;
int fromleaf = 0;
/* If we have the prev one, return it */
if (next_frame->prev)
return next_frame->prev;
/* On some machines it is possible to call a function without
setting up a stack frame for it. On these machines, we
define this macro to take two args; a frameinfo pointer
identifying a frame and a variable to set or clear if it is
or isn't leafless. */
/* Two macros defined in tm.h specify the machine-dependent
actions to be performed here.
First, get the frame's chain-pointer. If that is zero, the frame
is the outermost frame or a leaf called by the outermost frame.
This means that if start calls main without a frame, we'll return
0 (which is fine anyway).
Nope; there's a problem. This also returns when the current
routine is a leaf of main. This is unacceptable. We move
this to after the ffi test; I'd rather have backtraces from
start go curfluy than have an abort called from main not show
main. */
address = FRAME_CHAIN (next_frame);
if (!FRAME_CHAIN_VALID (address, next_frame))
return 0;
address = FRAME_CHAIN_COMBINE (address, next_frame);
if (address == 0)
return 0;
prev = (struct frame_info *) trace_alloc (sizeof (struct frame_info));
prev->saved_regs = NULL;
if (next_frame)
next_frame->prev = prev;
prev->next = next_frame;
prev->prev = (struct frame_info *) 0;
prev->frame = address;
/* This change should not be needed, FIXME! We should
determine whether any targets *need* INIT_FRAME_PC to happen
after INIT_EXTRA_FRAME_INFO and come up with a simple way to
express what goes on here.
INIT_EXTRA_FRAME_INFO is called from two places: create_new_frame
(where the PC is already set up) and here (where it isn't).
INIT_FRAME_PC is only called from here, always after
INIT_EXTRA_FRAME_INFO.
The catch is the MIPS, where INIT_EXTRA_FRAME_INFO requires the PC
value (which hasn't been set yet). Some other machines appear to
require INIT_EXTRA_FRAME_INFO before they can do INIT_FRAME_PC. Phoo.
We shouldn't need INIT_FRAME_PC_FIRST to add more complication to
an already overcomplicated part of GDB. gnu@cygnus.com, 15Sep92.
Assuming that some machines need INIT_FRAME_PC after
INIT_EXTRA_FRAME_INFO, one possible scheme:
SETUP_INNERMOST_FRAME()
Default version is just create_new_frame (read_fp ()),
read_pc ()). Machines with extra frame info would do that (or the
local equivalent) and then set the extra fields.
INIT_PREV_FRAME(fromleaf, prev)
Replace INIT_EXTRA_FRAME_INFO and INIT_FRAME_PC. This should
also return a flag saying whether to keep the new frame, or
whether to discard it, because on some machines (e.g. mips) it
is really awkward to have FRAME_CHAIN_VALID called *before*
INIT_EXTRA_FRAME_INFO (there is no good way to get information
deduced in FRAME_CHAIN_VALID into the extra fields of the new frame).
std_frame_pc(fromleaf, prev)
This is the default setting for INIT_PREV_FRAME. It just does what
the default INIT_FRAME_PC does. Some machines will call it from
INIT_PREV_FRAME (either at the beginning, the end, or in the middle).
Some machines won't use it.
kingdon@cygnus.com, 13Apr93, 31Jan94, 14Dec94. */
#ifdef INIT_FRAME_PC_FIRST
INIT_FRAME_PC_FIRST (fromleaf, prev);
#endif
#ifdef INIT_EXTRA_FRAME_INFO
INIT_EXTRA_FRAME_INFO (fromleaf, prev);
#endif
/* This entry is in the frame queue now, which is good since
FRAME_SAVED_PC may use that queue to figure out its value
(see tm-sparc.h). We want the pc saved in the inferior frame. */
INIT_FRAME_PC (fromleaf, prev);
/* If ->frame and ->pc are unchanged, we are in the process of getting
ourselves into an infinite backtrace. Some architectures check this
in FRAME_CHAIN or thereabouts, but it seems like there is no reason
this can't be an architecture-independent check. */
if (next_frame != NULL)
{
if (prev->frame == next_frame->frame
&& prev->pc == next_frame->pc)
{
next_frame->prev = NULL;
free (prev);
return NULL;
}
}
return prev;
}
#define SAVE(regno,disp) \
"stq $" #regno ", " #disp "(%0)\n"
int
__gnat_backtrace (void **array,
int size,
void *exclude_min,
void *exclude_max,
int skip_frames)
{
struct frame_info* top;
struct frame_info* current;
int cnt;
/* This function is not thread safe, protect it */
(*Lock_Task) ();
asm volatile (
SAVE (9,72)
SAVE (10,80)
SAVE (11,88)
SAVE (12,96)
SAVE (13,104)
SAVE (14,112)
SAVE (15,120)
SAVE (16,128)
SAVE (17,136)
SAVE (18,144)
SAVE (19,152)
SAVE (20,160)
SAVE (21,168)
SAVE (22,176)
SAVE (23,184)
SAVE (24,192)
SAVE (25,200)
SAVE (26,208)
SAVE (27,216)
SAVE (28,224)
SAVE (29,232)
SAVE (30,240)
: : "r" (&theRegisters));
trace_alloc_chain = NULL;
set_current_pc ();
top = current = get_current_frame ();
cnt = 0;
for (cnt = 0; cnt < skip_frames; cnt += 1) {
current = get_prev_frame (current);
}
cnt = 0;
while (cnt < size)
{
if (STOP_FRAME)
break;
if (current->pc < (CORE_ADDR) exclude_min
|| current->pc > (CORE_ADDR) exclude_max)
array[cnt++] = (void*) (current->pc + PC_ADJUST);
current = get_prev_frame (current);
}
free_trace_alloc ();
(*Unlock_Task) ();
return cnt;
}

88
gcc/ada/tb-ivms.c
View file

@ -1,88 +0,0 @@
/****************************************************************************
* *
* GNAT RUN-TIME COMPONENTS *
* *
* T R A C E B A C K - I t a n i u m / V M S *
* *
* C Implementation File *
* *
* Copyright (C) 2007-2011, AdaCore *
* *
* 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. *
* *
****************************************************************************/
/* Itanium Open/VMS implementation of backtrace. Use ICB (Invocation
Context Block) routines. */
#include <stdlib.h>
#include <vms/libicb.h>
/* Declare libicb routines. */
extern INVO_CONTEXT_BLK *LIB$I64_CREATE_INVO_CONTEXT (void *(*)(size_t),
void (*)(void *),
int);
extern void LIB$I64_FREE_INVO_CONTEXT (INVO_CONTEXT_BLK *);
extern int LIB$I64_GET_CURR_INVO_CONTEXT(INVO_CONTEXT_BLK *);
extern int LIB$I64_GET_PREV_INVO_CONTEXT(INVO_CONTEXT_BLK *);
/* Gcc internal headers poison malloc. So use xmalloc() when building the
compiler. */
#ifdef IN_RTS
#define BT_MALLOC malloc
#else
#define BT_MALLOC xmalloc
#endif
int
__gnat_backtrace (void **array, int size,
void *exclude_min, void *exclude_max, int skip_frames)
{
INVO_CONTEXT_BLK *ctxt;
int res = 0;
int n = 0;
/* Create the context. */
ctxt = LIB$I64_CREATE_INVO_CONTEXT (BT_MALLOC, free, 0);
if (ctxt == NULL)
return 0;
LIB$I64_GET_CURR_INVO_CONTEXT (ctxt);
while (1)
{
void *pc = (void *)ctxt->libicb$ih_pc;
if (pc == (void *)0)
break;
if (ctxt->libicb$v_bottom_of_stack)
break;
if (n >= skip_frames && (pc < exclude_min || pc > exclude_max))
{
array[res++] = (void *)(ctxt->libicb$ih_pc);
if (res == size)
break;
}
n++;
LIB$I64_GET_PREV_INVO_CONTEXT (ctxt);
}
/* Free the context. */
LIB$I64_FREE_INVO_CONTEXT (ctxt);
return res;
}

16
gcc/ada/tracebak.c
View file

@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
* Copyright (C) 2000-2012, Free Software Foundation, Inc. *
* Copyright (C) 2000-2014, 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- *
@ -95,19 +95,7 @@ extern void (*Unlock_Task) (void);
*-- Target specific implementations --*
*-------------------------------------*/
#if defined (__alpha_vxworks)
#include "tb-alvxw.c"
#elif defined (__ALPHA) && defined (__VMS__)
#include "tb-alvms.c"
#elif defined (__ia64__) && defined (__VMS__)
#include "tb-ivms.c"
#elif defined (_WIN64) && defined (__SEH__)
#if defined (_WIN64) && defined (__SEH__)
#include <windows.h>