-- messages. This variable is recursively saved on entry to processing the
-- construct, and restored on exit.
- function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
+ function Has_Sec_Stack_Call (N : Node_Id) return Boolean;
-- N is the node for an arbitrary construct. This function searches the
-- construct N to see if any expressions within it contain function
-- calls that use the secondary stack, returning True if any such call
-- proper trace of the value, useful in optimizations that get rid
-- of junk range checks.
- if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then
+ if not Has_Sec_Stack_Call (Analyzed_Bound) then
Analyze_And_Resolve (Original_Bound, Typ);
-- Ensure that the bound is valid. This check should not be
procedure Analyze_Loop_Statement (N : Node_Id) is
+ -- The following exception is raised by routine Prepare_Loop_Statement
+ -- to avoid further analysis of a transformed loop.
+
+ Skip_Analysis : exception;
+
function Disable_Constant (N : Node_Id) return Traverse_Result;
-- If N represents an E_Variable entity, set Is_True_Constant To False
- function Is_Container_Iterator (Iter : Node_Id) return Boolean;
- -- Given a loop iteration scheme, determine whether it is an Ada 2012
- -- container iteration.
+ procedure Disable_Constants is new Traverse_Proc (Disable_Constant);
+ -- Helper for Analyze_Loop_Statement, to unset Is_True_Constant on
+ -- variables referenced within an OpenACC construct.
- function Is_Wrapped_In_Block (N : Node_Id) return Boolean;
- -- Determine whether loop statement N has been wrapped in a block to
- -- capture finalization actions that may be generated for container
- -- iterators. Prevents infinite recursion when block is analyzed.
- -- Routine is a noop if loop is single statement within source block.
+ procedure Prepare_Loop_Statement (Iter : Node_Id);
+ -- Determine whether loop statement N with iteration scheme Iter must be
+ -- transformed prior to analysis, and if so, perform it. The routine
+ -- raises Skip_Analysis to prevent further analysis of the transformed
+ -- loop.
----------------------
-- Disable_Constant --
then
Set_Is_True_Constant (Entity (N), False);
end if;
+
return OK;
end Disable_Constant;
- procedure Disable_Constants is new Traverse_Proc (Disable_Constant);
- -- Helper for Analyze_Loop_Statement, to unset Is_True_Constant on
- -- variables referenced within an OpenACC environment.
+ ----------------------------
+ -- Prepare_Loop_Statement --
+ ----------------------------
+
+ procedure Prepare_Loop_Statement (Iter : Node_Id) is
+ function Has_Sec_Stack_Default_Iterator
+ (Cont_Typ : Entity_Id) return Boolean;
+ pragma Inline (Has_Sec_Stack_Default_Iterator);
+ -- Determine whether container type Cont_Typ has a default iterator
+ -- that requires secondary stack management.
+
+ function Is_Sec_Stack_Iteration_Primitive
+ (Cont_Typ : Entity_Id;
+ Iter_Prim_Nam : Name_Id) return Boolean;
+ pragma Inline (Is_Sec_Stack_Iteration_Primitive);
+ -- Determine whether container type Cont_Typ has an iteration routine
+ -- described by its name Iter_Prim_Nam that requires secondary stack
+ -- management.
+
+ function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean;
+ pragma Inline (Is_Wrapped_In_Block);
+ -- Determine whether arbitrary statement Stmt is the sole statement
+ -- wrapped within some block, excluding pragmas.
+
+ procedure Prepare_Iterator_Loop (Iter_Spec : Node_Id);
+ pragma Inline (Prepare_Iterator_Loop);
+ -- Prepare an iterator loop with iteration specification Iter_Spec
+ -- for transformation if needed.
+
+ procedure Prepare_Param_Spec_Loop (Param_Spec : Node_Id);
+ pragma Inline (Prepare_Param_Spec_Loop);
+ -- Prepare a discrete loop with parameter specification Param_Spec
+ -- for transformation if needed.
+
+ procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean);
+ pragma Inline (Wrap_Loop_Statement);
+ -- Wrap loop statement N within a block. Flag Manage_Sec_Stack must
+ -- be set when the block must mark and release the secondary stack.
+
+ ------------------------------------
+ -- Has_Sec_Stack_Default_Iterator --
+ ------------------------------------
+
+ function Has_Sec_Stack_Default_Iterator
+ (Cont_Typ : Entity_Id) return Boolean
+ is
+ Def_Iter : constant Node_Id :=
+ Find_Value_Of_Aspect
+ (Cont_Typ, Aspect_Default_Iterator);
+ begin
+ return
+ Present (Def_Iter)
+ and then Requires_Transient_Scope (Etype (Def_Iter));
+ end Has_Sec_Stack_Default_Iterator;
+
+ --------------------------------------
+ -- Is_Sec_Stack_Iteration_Primitive --
+ --------------------------------------
+
+ function Is_Sec_Stack_Iteration_Primitive
+ (Cont_Typ : Entity_Id;
+ Iter_Prim_Nam : Name_Id) return Boolean
+ is
+ Iter_Prim : constant Entity_Id :=
+ Get_Iterable_Type_Primitive
+ (Cont_Typ, Iter_Prim_Nam);
+ begin
+ return
+ Present (Iter_Prim)
+ and then Requires_Transient_Scope (Etype (Iter_Prim));
+ end Is_Sec_Stack_Iteration_Primitive;
- ---------------------------
- -- Is_Container_Iterator --
- ---------------------------
+ -------------------------
+ -- Is_Wrapped_In_Block --
+ -------------------------
- function Is_Container_Iterator (Iter : Node_Id) return Boolean is
- begin
- -- Infinite loop
+ function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean is
+ Blk_HSS : Node_Id;
+ Blk_Id : Entity_Id;
+ Blk_Stmt : Node_Id;
- if No (Iter) then
- return False;
+ begin
+ Blk_Id := Current_Scope;
- -- While loop
+ -- The current context is a block. Inspect the statements of the
+ -- block to determine whether it wraps Stmt.
+
+ if Ekind (Blk_Id) = E_Block
+ and then Present (Block_Node (Blk_Id))
+ then
+ Blk_HSS :=
+ Handled_Statement_Sequence (Parent (Block_Node (Blk_Id)));
+
+ -- Skip leading pragmas introduced for invariant and predicate
+ -- checks.
+
+ Blk_Stmt := First (Statements (Blk_HSS));
+ while Present (Blk_Stmt)
+ and then Nkind (Blk_Stmt) = N_Pragma
+ loop
+ Next (Blk_Stmt);
+ end loop;
+
+ return Blk_Stmt = Stmt and then No (Next (Blk_Stmt));
+ end if;
- elsif Present (Condition (Iter)) then
return False;
+ end Is_Wrapped_In_Block;
- -- for Def_Id in [reverse] Name loop
- -- for Def_Id [: Subtype_Indication] of [reverse] Name loop
+ ---------------------------
+ -- Prepare_Iterator_Loop --
+ ---------------------------
- elsif Present (Iterator_Specification (Iter)) then
- declare
- Nam : constant Node_Id := Name (Iterator_Specification (Iter));
- Nam_Copy : Node_Id;
+ procedure Prepare_Iterator_Loop (Iter_Spec : Node_Id) is
+ Cont_Typ : Entity_Id;
+ Nam : Node_Id;
+ Nam_Copy : Node_Id;
- begin
+ begin
+ -- The iterator specification has syntactic errors. Transform the
+ -- loop into an infinite loop in order to safely perform at least
+ -- some minor analysis. This check must come first.
+
+ if Error_Posted (Iter_Spec) then
+ Set_Iteration_Scheme (N, Empty);
+ Analyze (N);
+
+ raise Skip_Analysis;
+
+ -- Nothing to do when the loop is already wrapped in a block
+
+ elsif Is_Wrapped_In_Block (N) then
+ null;
+
+ -- Otherwise the iterator loop traverses an array or a container
+ -- and appears in the form
+ --
+ -- for Def_Id in [reverse] Iterator_Name loop
+ -- for Def_Id [: Subtyp_Indic] of [reverse] Iterable_Name loop
+
+ else
+ -- Prepare a copy of the iterated name for preanalysis. The
+ -- copy is semi inserted into the tree by setting its Parent
+ -- pointer.
+
+ Nam := Name (Iter_Spec);
Nam_Copy := New_Copy_Tree (Nam);
Set_Parent (Nam_Copy, Parent (Nam));
+
+ -- Determine what the loop is iterating on
+
Preanalyze_Range (Nam_Copy);
+ Cont_Typ := Etype (Nam_Copy);
- -- The only two options here are iteration over a container or
- -- an array.
+ -- The iterator loop is traversing an array. This case does not
+ -- require any transformation.
- return not Is_Array_Type (Etype (Nam_Copy));
- end;
+ if Is_Array_Type (Cont_Typ) then
+ null;
- -- for Def_Id in [reverse] Discrete_Subtype_Definition loop
+ -- Otherwise unconditionally wrap the loop statement within
+ -- a block. The expansion of iterator loops may relocate the
+ -- iterator outside the loop, thus "leaking" its entity into
+ -- the enclosing scope. Wrapping the loop statement allows
+ -- for multiple iterator loops using the same iterator name
+ -- to coexist within the same scope.
+ --
+ -- The block must manage the secondary stack when the iterator
+ -- loop is traversing a container using either
+ --
+ -- * A default iterator obtained on the secondary stack
+ --
+ -- * Call to Iterate where the iterator is returned on the
+ -- secondary stack.
+ --
+ -- * Combination of First, Next, and Has_Element where the
+ -- first two return a cursor on the secondary stack.
- else
- declare
- LP : constant Node_Id := Loop_Parameter_Specification (Iter);
- DS : constant Node_Id := Discrete_Subtype_Definition (LP);
- DS_Copy : Node_Id;
+ else
+ Wrap_Loop_Statement
+ (Manage_Sec_Stack =>
+ Has_Sec_Stack_Default_Iterator (Cont_Typ)
+ or else Has_Sec_Stack_Call (Nam_Copy)
+ or else Is_Sec_Stack_Iteration_Primitive
+ (Cont_Typ, Name_First)
+ or else Is_Sec_Stack_Iteration_Primitive
+ (Cont_Typ, Name_Next));
+ end if;
+ end if;
+ end Prepare_Iterator_Loop;
- begin
- DS_Copy := New_Copy_Tree (DS);
- Set_Parent (DS_Copy, Parent (DS));
- Preanalyze_Range (DS_Copy);
+ -----------------------------
+ -- Prepare_Param_Spec_Loop --
+ -----------------------------
- -- Check for a call to Iterate () or an expression with
- -- an iterator type.
+ procedure Prepare_Param_Spec_Loop (Param_Spec : Node_Id) is
+ High : Node_Id;
+ Low : Node_Id;
+ Rng : Node_Id;
+ Rng_Copy : Node_Id;
+ Rng_Typ : Entity_Id;
- return
- (Nkind (DS_Copy) = N_Function_Call
- and then Needs_Finalization (Etype (DS_Copy)))
- or else Is_Iterator (Etype (DS_Copy));
- end;
- end if;
- end Is_Container_Iterator;
+ begin
+ Rng := Discrete_Subtype_Definition (Param_Spec);
- -------------------------
- -- Is_Wrapped_In_Block --
- -------------------------
+ -- Nothing to do when the loop is already wrapped in a block
- function Is_Wrapped_In_Block (N : Node_Id) return Boolean is
- HSS : Node_Id;
- Stat : Node_Id;
+ if Is_Wrapped_In_Block (N) then
+ null;
- begin
+ -- The parameter specification appears in the form
+ --
+ -- for Def_Id in Subtype_Mark Constraint loop
- -- Check if current scope is a block that is not a transient block.
+ elsif Nkind (Rng) = N_Subtype_Indication
+ and then Nkind (Range_Expression (Constraint (Rng))) = N_Range
+ then
+ Rng := Range_Expression (Constraint (Rng));
- if Ekind (Current_Scope) /= E_Block
- or else No (Block_Node (Current_Scope))
- then
- return False;
+ -- Preanalyze the bounds of the range constraint
- else
- HSS :=
- Handled_Statement_Sequence (Parent (Block_Node (Current_Scope)));
+ Low := New_Copy_Tree (Low_Bound (Rng));
+ High := New_Copy_Tree (High_Bound (Rng));
- -- Skip leading pragmas that may be introduced for invariant and
- -- predicate checks.
+ Preanalyze (Low);
+ Preanalyze (High);
- Stat := First (Statements (HSS));
- while Present (Stat) and then Nkind (Stat) = N_Pragma loop
- Stat := Next (Stat);
- end loop;
+ -- The bounds contain at least one function call that returns
+ -- on the secondary stack. Note that the loop must be wrapped
+ -- only when such a call exists.
+
+ if Has_Sec_Stack_Call (Low)
+ or else
+ Has_Sec_Stack_Call (High)
+ then
+ Wrap_Loop_Statement (Manage_Sec_Stack => True);
+ end if;
+
+ -- Otherwise the parameter specification appears in the form
+ --
+ -- for Def_Id in Range loop
+
+ else
+ -- Prepare a copy of the discrete range for preanalysis. The
+ -- copy is semi inserted into the tree by setting its Parent
+ -- pointer.
+
+ Rng_Copy := New_Copy_Tree (Rng);
+ Set_Parent (Rng_Copy, Parent (Rng));
+
+ -- Determine what the loop is iterating on
+
+ Preanalyze_Range (Rng_Copy);
+ Rng_Typ := Etype (Rng_Copy);
+
+ -- Wrap the loop statement within a block in order to manage
+ -- the secondary stack when the discrete range is
+ --
+ -- * Either a Forward_Iterator or a Reverse_Iterator
+ --
+ -- * Function call whose return type requires finalization
+ -- actions.
+
+ -- ??? it is unclear why using Has_Sec_Stack_Call directly on
+ -- the discrete range causes the freeze node of an itype to be
+ -- in the wrong scope in complex assertion expressions.
+
+ if Is_Iterator (Rng_Typ)
+ or else (Nkind (Rng_Copy) = N_Function_Call
+ and then Needs_Finalization (Rng_Typ))
+ then
+ Wrap_Loop_Statement (Manage_Sec_Stack => True);
+ end if;
+ end if;
+ end Prepare_Param_Spec_Loop;
+
+ -------------------------
+ -- Wrap_Loop_Statement --
+ -------------------------
- return Stat = N and then No (Next (Stat));
+ procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Blk : Node_Id;
+ Blk_Id : Entity_Id;
+
+ begin
+ Blk :=
+ Make_Block_Statement (Loc,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Relocate_Node (N))));
+
+ Add_Block_Identifier (Blk, Blk_Id);
+ Set_Uses_Sec_Stack (Blk_Id, Manage_Sec_Stack);
+
+ Rewrite (N, Blk);
+ Analyze (N);
+
+ raise Skip_Analysis;
+ end Wrap_Loop_Statement;
+
+ -- Local variables
+
+ Iter_Spec : constant Node_Id := Iterator_Specification (Iter);
+ Param_Spec : constant Node_Id := Loop_Parameter_Specification (Iter);
+
+ -- Start of processing for Prepare_Loop_Statement
+
+ begin
+ if Present (Iter_Spec) then
+ Prepare_Iterator_Loop (Iter_Spec);
+
+ elsif Present (Param_Spec) then
+ Prepare_Param_Spec_Loop (Param_Spec);
end if;
- end Is_Wrapped_In_Block;
+ end Prepare_Loop_Statement;
-- Local declarations
Set_Has_Created_Identifier (N);
end if;
- -- If the iterator specification has a syntactic error, transform
- -- construct into an infinite loop to prevent a crash and perform
- -- some analysis.
-
- if Present (Iter)
- and then Present (Iterator_Specification (Iter))
- and then Error_Posted (Iterator_Specification (Iter))
- then
- Set_Iteration_Scheme (N, Empty);
- Analyze (N);
- return;
- end if;
-
- -- Iteration over a container in Ada 2012 involves the creation of a
- -- controlled iterator object. Wrap the loop in a block to ensure the
- -- timely finalization of the iterator and release of container locks.
- -- The same applies to the use of secondary stack when obtaining an
- -- iterator.
-
- if Ada_Version >= Ada_2012
- and then Is_Container_Iterator (Iter)
- and then not Is_Wrapped_In_Block (N)
- then
- declare
- Block_Nod : Node_Id;
- Block_Id : Entity_Id;
-
- begin
- Block_Nod :=
- Make_Block_Statement (Loc,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Relocate_Node (N))));
-
- Add_Block_Identifier (Block_Nod, Block_Id);
-
- -- The expansion of iterator loops generates an iterator in order
- -- to traverse the elements of a container:
-
- -- Iter : <iterator type> := Iterate (Container)'reference;
-
- -- The iterator is controlled and returned on the secondary stack.
- -- The analysis of the call to Iterate establishes a transient
- -- scope to deal with the secondary stack management, but never
- -- really creates a physical block as this would kill the iterator
- -- too early (see Wrap_Transient_Declaration). To address this
- -- case, mark the generated block as needing secondary stack
- -- management.
-
- Set_Uses_Sec_Stack (Block_Id);
-
- Rewrite (N, Block_Nod);
- Analyze (N);
- return;
- end;
- end if;
-
- -- Wrap the loop in a block when the evaluation of the loop iterator
- -- relies on the secondary stack. Required to ensure releasing the
- -- secondary stack as soon as the loop completes.
-
- if Present (Iter)
- and then Present (Loop_Parameter_Specification (Iter))
- and then not Is_Wrapped_In_Block (N)
- then
- declare
- LPS : constant Node_Id := Loop_Parameter_Specification (Iter);
- DSD : constant Node_Id :=
- Original_Node (Discrete_Subtype_Definition (LPS));
-
- Block_Id : Entity_Id;
- Block_Nod : Node_Id;
- HB : Node_Id;
- LB : Node_Id;
+ -- Determine whether the loop statement must be transformed prior to
+ -- analysis, and if so, perform it. This early modification is needed
+ -- when:
+ --
+ -- * The loop has an erroneous iteration scheme. In this case the
+ -- loop is converted into an infinite loop in order to perform
+ -- minor analysis.
+ --
+ -- * The loop is an Ada 2012 iterator loop. In this case the loop is
+ -- wrapped within a block to provide a local scope for the iterator.
+ -- If the iterator specification requires the secondary stack in any
+ -- way, the block is marked in order to manage it.
+ --
+ -- * The loop is using a parameter specification where the discrete
+ -- range requires the secondary stack. In this case the loop is
+ -- wrapped within a block in order to manage the secondary stack.
- begin
- if Nkind (DSD) = N_Subtype_Indication
- and then Nkind (Range_Expression (Constraint (DSD))) = N_Range
- then
- LB :=
- New_Copy_Tree
- (Low_Bound (Range_Expression (Constraint (DSD))));
- HB :=
- New_Copy_Tree
- (High_Bound (Range_Expression (Constraint (DSD))));
-
- Preanalyze (LB);
- Preanalyze (HB);
-
- if Has_Call_Using_Secondary_Stack (LB)
- or else Has_Call_Using_Secondary_Stack (HB)
- then
- Block_Nod :=
- Make_Block_Statement (Loc,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Relocate_Node (N))));
-
- Add_Block_Identifier (Block_Nod, Block_Id);
- Set_Uses_Sec_Stack (Block_Id);
- Rewrite (N, Block_Nod);
- Analyze (N);
- return;
- end if;
- end if;
- end;
+ if Present (Iter) then
+ Prepare_Loop_Statement (Iter);
end if;
-- Kill current values on entry to loop, since statements in the body of
if Is_OpenAcc_Environment (Stmt) then
Disable_Constants (Stmt);
end if;
+
+ exception
+ when Skip_Analysis =>
+ null;
end Analyze_Loop_Statement;
----------------------------
end if;
end Check_Unreachable_Code;
- ------------------------------------
- -- Has_Call_Using_Secondary_Stack --
- ------------------------------------
+ ------------------------
+ -- Has_Sec_Stack_Call --
+ ------------------------
- function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is
+ function Has_Sec_Stack_Call (N : Node_Id) return Boolean is
function Check_Call (N : Node_Id) return Traverse_Result;
-- Check if N is a function call which uses the secondary stack
end loop;
Subp := Entity (Nam);
- Typ := Etype (Subp);
- if Requires_Transient_Scope (Typ) then
- return Abandon;
+ if Present (Subp) then
+ Typ := Etype (Subp);
- elsif Sec_Stack_Needed_For_Return (Subp) then
- return Abandon;
+ if Requires_Transient_Scope (Typ) then
+ return Abandon;
+
+ elsif Sec_Stack_Needed_For_Return (Subp) then
+ return Abandon;
+ end if;
end if;
end if;
function Check_Calls is new Traverse_Func (Check_Call);
- -- Start of processing for Has_Call_Using_Secondary_Stack
+ -- Start of processing for Has_Sec_Stack_Call
begin
return Check_Calls (N) = Abandon;
- end Has_Call_Using_Secondary_Stack;
+ end Has_Sec_Stack_Call;
----------------------
-- Preanalyze_Range --
projects / gcc.git / commitdiff