Skip to content

R
riscv-gcc-1
Commit dbe13a37 by Ed Schonberg Committed by Arnaud Charlet
Options

exp_ch7.ads, [...] (Expand_Cleanup_Actions): Set Sloc of inserted cleanup code… 

exp_ch7.ads, [...] (Expand_Cleanup_Actions): Set Sloc of inserted cleanup code appropriately for GDB use.

2007-04-20  Ed Schonberg  <schonberg@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* exp_ch7.ads, exp_ch7.adb (Expand_Cleanup_Actions): Set Sloc of
	inserted cleanup code appropriately for GDB use.
	(Make_Deep_Proc): Use Make_Handler_For_Ctrl_Operation to create
	exception handler for Deep_Adjust or Deep_Finalize.
	(Make_Handler_For_Ctrl_Operation): New subprogram. When runtime entity
	Raise_From_Controlled_Operation is available, use a call to that
	subprogram instead of a plain "raise Program_Error" node to raise
	Program_Error if an exception is propagated from an Adjust or Finalize
	operation.
	(Insert_Actions_In_Scope_Around): If the statement to be wrapped
	appears in the optional statement list of a triggering alternative, the
	scope actions can be inserted directly there, and not in the list that
	includes the asynchronous select itself.

From-SVN: r125400
parent 7888a6ae
Showing with 155 additions and 83 deletions
gcc/ada/exp_ch7.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -40,7 +40,6 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Lib; use Lib;
with Hostparm; use Hostparm;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
......@@ -58,6 +57,7 @@ with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
......@@ -90,27 +90,33 @@ package body Exp_Ch7 is
-- declaration and the secondary stack deallocation is done in the
-- proper enclosing scope (see Wrap_Transient_Declaration for details)
-- Note about function returning tagged types: It has been decided to
-- always allocate their result in the secondary stack while it is not
-- Note about functions returning tagged types: It has been decided to
-- always allocate their result in the secondary stack, even though is not
-- absolutely mandatory when the tagged type is constrained because the
-- caller knows the size of the returned object and thus could allocate the
-- result in the primary stack. But, allocating them always in the
-- secondary stack simplifies many implementation hassles:
-- result in the primary stack. An exception to this is when the function
-- builds its result in place, as is done for functions with inherently
-- limited result types for Ada 2005. In that case, certain callers may
-- pass the address of a constrained object as the target object for the
-- function result.
-- - If it is dispatching function call, the computation of the size of
-- By allocating tagged results in the secondary stack a number of
-- implementation difficulties are avoided:
-- - If it is a dispatching function call, the computation of the size of
-- the result is possible but complex from the outside.
-- - If the returned type is controlled, the assignment of the returned
-- value to the anonymous object involves an Adjust, and we have no
-- easy way to access the anonymous object created by the back-end
-- easy way to access the anonymous object created by the back end.
-- - If the returned type is class-wide, this is an unconstrained type
-- anyway
-- anyway.
-- Furthermore, the little loss in efficiency which is the result of this
-- decision is not such a big deal because function returning tagged types
-- are not very much used in real life as opposed to functions returning
-- access to a tagged type
-- Furthermore, the small loss in efficiency which is the result of this
-- decision is not such a big deal because functions returning tagged types
-- are not as common in practice compared to functions returning access to
-- a tagged type.
--------------------------------------------------
-- Transient Blocks and Finalization Management --
......@@ -245,8 +251,8 @@ package body Exp_Ch7 is
-- controlled components (Has_Controlled_Component flag set). In the first
-- case the procedures to call are the user-defined primitive operations
-- Initialize/Adjust/Finalize. In the second case, GNAT generates
-- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge of
-- calling the former procedures on the controlled components.
-- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
-- of calling the former procedures on the controlled components.
-- For records with Has_Controlled_Component set, a hidden "controller"
-- component is inserted. This controller component contains its own
......@@ -255,9 +261,9 @@ package body Exp_Ch7 is
-- technique facilitates the management of objects whose number of
-- controlled components changes during execution. This controller
-- component is itself controlled and is attached to the upper-level
-- finalization chain. Its adjust primitive is in charge of calling
-- adjust on the components and adusting the finalization pointer to
-- match their new location (see a-finali.adb).
-- finalization chain. Its adjust primitive is in charge of calling adjust
-- on the components and adusting the finalization pointer to match their
-- new location (see a-finali.adb).
-- It is not possible to use a similar technique for arrays that have
-- Has_Controlled_Component set. In this case, deep procedures are
......@@ -265,11 +271,11 @@ package body Exp_Ch7 is
-- detachment on the finalization list for all component.
-- Initialize calls: they are generated for declarations or dynamic
-- allocations of Controlled objects with no initial value. They are
-- always followed by an attachment to the current Finalization
-- Chain. For the dynamic allocation case this the chain attached to
-- the scope of the access type definition otherwise, this is the chain
-- of the current scope.
-- allocations of Controlled objects with no initial value. They are always
-- followed by an attachment to the current Finalization Chain. For the
-- dynamic allocation case this the chain attached to the scope of the
-- access type definition otherwise, this is the chain of the current
-- scope.
-- Adjust Calls: They are generated on 2 occasions: (1) for
-- declarations or dynamic allocations of Controlled objects with an
......@@ -280,21 +286,26 @@ package body Exp_Ch7 is
-- Finalization Calls: They are generated on (1) scope exit, (2)
-- assignments, (3) unchecked deallocations. In case (3) they have to
-- be detached from the final chain, in case (2) they must not and in
-- case (1) this is not important since we are exiting the scope
-- anyway.
-- case (1) this is not important since we are exiting the scope anyway.
-- Other details:
-- - Type extensions will have a new record controller at each derivation
-- level containing controlled components.
-- - For types that are both Is_Controlled and Has_Controlled_Components,
-- the record controller and the object itself are handled separately.
-- It could seem simpler to attach the object at the end of its record
-- controller but this would not tackle view conversions properly.
-- - A classwide type can always potentially have controlled components
-- but the record controller of the corresponding actual type may not
-- be known at compile time so the dispatch table contains a special
-- field that allows to compute the offset of the record controller
-- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset
-- Type extensions will have a new record controller at each derivation
-- level containing controlled components. The record controller for
-- the parent/ancestor is attached to the finalization list of the
-- extension's record controller (i.e. the parent is like a component
-- of the extension).
-- For types that are both Is_Controlled and Has_Controlled_Components,
-- the record controller and the object itself are handled separately.
-- It could seem simpler to attach the object at the end of its record
-- controller but this would not tackle view conversions properly.
-- A classwide type can always potentially have controlled components
-- but the record controller of the corresponding actual type may not
-- be known at compile time so the dispatch table contains a special
-- field that allows to compute the offset of the record controller
-- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
-- Here is a simple example of the expansion of a controlled block :
......@@ -1031,6 +1042,12 @@ package body Exp_Ch7 is
Wrap_Node : Node_Id;
begin
-- Nothing to do for virtual machines where memory is GCed
if VM_Target /= No_VM then
return;
end if;
-- Do not create a transient scope if we are already inside one
for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
......@@ -1066,7 +1083,7 @@ package body Exp_Ch7 is
null;
else
New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
Set_Scope_Is_Transient;
if Sec_Stack then
......@@ -1089,27 +1106,25 @@ package body Exp_Ch7 is
----------------------------
procedure Expand_Cleanup_Actions (N : Node_Id) is
Loc : Source_Ptr;
S : constant Entity_Id :=
Current_Scope;
Flist : constant Entity_Id :=
Finalization_Chain_Entity (S);
Is_Task : constant Boolean :=
(Nkind (Original_Node (N)) = N_Task_Body);
Is_Master : constant Boolean :=
S : constant Entity_Id := Current_Scope;
Flist : constant Entity_Id := Finalization_Chain_Entity (S);
Is_Task : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body;
Is_Master : constant Boolean :=
Nkind (N) /= N_Entry_Body
and then Is_Task_Master (N);
Is_Protected : constant Boolean :=
Is_Protected : constant Boolean :=
Nkind (N) = N_Subprogram_Body
and then Is_Protected_Subprogram_Body (N);
Is_Task_Allocation : constant Boolean :=
Is_Task_Allocation : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Task_Allocation_Block (N);
Is_Asynchronous_Call : constant Boolean :=
Is_Asynchronous_Call : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Asynchronous_Call_Block (N);
Clean : Entity_Id;
Loc : Source_Ptr;
Mark : Entity_Id := Empty;
New_Decls : constant List_Id := New_List;
Blok : Node_Id;
......@@ -1120,21 +1135,19 @@ package body Exp_Ch7 is
Old_Poll : Boolean;
begin
-- Compute a location that is not directly in the user code in
-- order to avoid to generate confusing debug info. A good
-- approximation is the name of the outer user-defined scope
declare
S1 : Entity_Id := S;
begin
while not Comes_From_Source (S1) and then S1 /= Standard_Standard loop
S1 := Scope (S1);
end loop;
Loc := Sloc (S1);
end;
-- If we are generating expanded code for debugging purposes, use
-- the Sloc of the point of insertion for the cleanup code. The Sloc
-- will be updated subsequently to reference the proper line in the
-- .dg file. If we are not debugging generated code, use instead
-- No_Location, so that no debug information is generated for the
-- cleanup code. This makes the behavior of the NEXT command in GDB
-- monotonic, and makes the placement of breakpoints more accurate.
if Debug_Generated_Code then
Loc := Sloc (S);
else
Loc := No_Location;
end if;
-- There are cleanup actions only if the secondary stack needs
-- releasing or some finalizations are needed or in the context
......@@ -1194,12 +1207,12 @@ package body Exp_Ch7 is
-- If secondary stack is in use, expand:
-- _Mxx : constant Mark_Id := SS_Mark;
-- Suppress calls to SS_Mark and SS_Release if Java_VM,
-- since we never use the secondary stack on the JVM.
-- Suppress calls to SS_Mark and SS_Release if VM_Target,
-- since we never use the secondary stack on the VM.
if Uses_Sec_Stack (Current_Scope)
and then not Sec_Stack_Needed_For_Return (Current_Scope)
and then not Java_VM
and then VM_Target = No_VM
then
Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
Append_To (New_Decls,
......@@ -1565,7 +1578,7 @@ package body Exp_Ch7 is
-- This is done only for non-generic packages
if Ekind (Ent) = E_Package then
New_Scope (Corresponding_Spec (N));
Push_Scope (Corresponding_Spec (N));
Build_Task_Activation_Call (N);
Pop_Scope;
end if;
......@@ -1629,8 +1642,7 @@ package body Exp_Ch7 is
-- have a specific separate compilation unit for that).
if No_Body then
New_Scope (Defining_Entity (N));
Push_Scope (Defining_Entity (N));
if Has_RACW (Defining_Entity (N)) then
......@@ -2016,12 +2028,17 @@ package body Exp_Ch7 is
Target : Node_Id;
begin
-- If the node to be wrapped is the triggering alternative of an
-- If the node to be wrapped is the triggering statement of an
-- asynchronous select, it is not part of a statement list. The
-- actions must be inserted before the Select itself, which is
-- part of some list of statements.
-- part of some list of statements. Note that the triggering
-- alternative includes the triggering statement and an optional
-- statement list. If the node to be wrapped is part of that list,
-- the normal insertion applies.
if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative then
if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative
and then not Is_List_Member (Node_To_Be_Wrapped)
then
Target := Parent (Parent (Node_To_Be_Wrapped));
else
Target := N;
......@@ -2661,12 +2678,7 @@ package body Exp_Ch7 is
Parameter_Type => New_Reference_To (Type_B, Loc)));
if Prim = Finalize_Case or else Prim = Adjust_Case then
Handler := New_List (
Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Make_Raise_Program_Error (Loc,
Reason => PE_Finalize_Raised_Exception))));
Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc));
end if;
Proc_Name :=
......@@ -2932,6 +2944,61 @@ package body Exp_Ch7 is
return Res;
end Make_Final_Call;
-------------------------------------
-- Make_Handler_For_Ctrl_Operation --
-------------------------------------
-- Generate:
-- when E : others =>
-- Raise_From_Controlled_Operation (X => E);
-- or:
-- when others =>
-- raise Program_Error [finalize raised exception];
-- depending on whether Raise_From_Controlled_Operation is available
function Make_Handler_For_Ctrl_Operation
(Loc : Source_Ptr) return Node_Id
is
E_Occ : Entity_Id;
-- Choice parameter (for the first case above)
Raise_Node : Node_Id;
-- Procedure call or raise statement
begin
if RTE_Available (RE_Raise_From_Controlled_Operation) then
-- Standard runtime: add choice parameter E, and pass it to
-- Raise_From_Controlled_Operation so that the original exception
-- name and message can be recorded in the exception message for
-- Program_Error.
E_Occ := Make_Defining_Identifier (Loc, Name_E);
Raise_Node := Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (E_Occ, Loc)));
else
-- Restricted runtime: exception messages are not supported
E_Occ := Empty;
Raise_Node := Make_Raise_Program_Error (Loc,
Reason => PE_Finalize_Raised_Exception);
end if;
return Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Choice_Parameter => E_Occ,
Statements => New_List (Raise_Node));
end Make_Handler_For_Ctrl_Operation;
--------------------
-- Make_Init_Call --
--------------------
......@@ -3069,7 +3136,8 @@ package body Exp_Ch7 is
begin
-- Case where only secondary stack use is involved
if Uses_Sec_Stack (Current_Scope)
if VM_Target = No_VM
and then Uses_Sec_Stack (Current_Scope)
and then No (Flist)
and then Nkind (Action) /= N_Return_Statement
and then Nkind (Par) /= N_Exception_Handler
......@@ -3136,7 +3204,6 @@ package body Exp_Ch7 is
declare
Last_Inserted : Node_Id := Prev (Action);
begin
if Present (Last_Inserted) then
Freeze_All (First_Entity (Current_Scope), Last_Inserted);
......@@ -3340,7 +3407,7 @@ package body Exp_Ch7 is
-- released upon its exit unless this is a function that returns on
-- the sec stack in which case this will be done by the caller.
if Uses_SS then
if VM_Target = No_VM and then Uses_SS then
S := Enclosing_Dynamic_Scope (S);
if Ekind (S) = E_Function
......@@ -3428,7 +3495,7 @@ package body Exp_Ch7 is
-- end _Clean;
-- begin
-- <Instr uction>;
-- <Instruction>;
-- at end
-- _Clean;
-- end;
......
gcc/ada/exp_ch7.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -24,6 +24,7 @@
-- --
------------------------------------------------------------------------------
with Namet; use Namet;
with Types; use Types;
package Exp_Ch7 is
......@@ -163,6 +164,10 @@ package Exp_Ch7 is
-- say attach the result of the call to the current finalization list,
-- which is the one of the transient scope created for such constructs.
function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id;
-- Generate an implicit exception handler with an 'others' choice,
-- converting any occurrence to a raise of Program_Error.
--------------------------------------------
-- Task and Protected Object finalization --
--------------------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment