-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
+with Fname; use Fname;
with Freeze; use Freeze;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Validsw; use Validsw;
-- For each actual of an in-out parameter which is a numeric conversion
-- of the form T(A), where A denotes a variable, we insert the declaration:
--
- -- Temp : T := T(A);
+ -- Temp : T := T (A);
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
--
- -- A := T' (Temp);
+ -- A := TypeA (Temp);
--
- -- after the call. Here T' is the actual type of variable A.
+ -- after the call. Here TypeA is the actual type of variable A.
-- For out parameters, the initial declaration has no expression.
- -- If A is not an entity name, we generate instead:
+ -- If A is not an entity name, we generate instead:
--
- -- Var : T' renames A;
+ -- Var : TypeA renames A;
-- Temp : T := Var; -- omitting expression for out parameter.
-- ...
- -- Var := T' (Temp);
+ -- Var := TypeA (Temp);
--
-- For other in-out parameters, we emit the required constraint checks
-- before and/or after the call.
-
+ --
-- For all parameter modes, actuals that denote components and slices
-- of packed arrays are expanded into suitable temporaries.
procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Var_List : Elist_Id := New_Elmt_List;
+ Var_List : constant Elist_Id := New_Elmt_List;
-- List of globals referenced by body of procedure
- Call_List : Elist_Id := New_Elmt_List;
+ Call_List : constant Elist_Id := New_Elmt_List;
-- List of recursive calls in body of procedure
- Shad_List : Elist_Id := New_Elmt_List;
+ Shad_List : constant Elist_Id := New_Elmt_List;
-- List of entity id's for entities created to capture the
-- value of referenced globals on entry to the procedure.
elsif Ekind (Ent) /= E_Variable
or else not Is_Scalar_Type (Etype (Ent))
- or else Is_Volatile (Ent)
+ or else Treat_As_Volatile (Ent)
then
return Abandon;
-- since we won't be able to generate the code to handle the
-- recursion in any case.
- if Restrictions (No_Implicit_Conditionals) then
+ if Restriction_Active (No_Implicit_Conditionals) then
return;
end if;
E_Formal : Entity_Id;
procedure Add_Call_By_Copy_Code;
- -- For In and In-Out parameters, where the parameter must be passed
- -- by copy, this routine generates a temporary variable into which
- -- the actual is copied, and then passes this as the parameter. This
- -- routine also takes care of any constraint checks required for the
- -- type conversion case (on both the way in and the way out).
+ -- For cases where the parameter must be passed by copy, this routine
+ -- generates a temporary variable into which the actual is copied and
+ -- then passes this as the parameter. For an OUT or IN OUT parameter,
+ -- an assignment is also generated to copy the result back. The call
+ -- also takes care of any constraint checks required for the type
+ -- conversion case (on both the way in and the way out).
procedure Add_Packed_Call_By_Copy_Code;
-- This is used when the actual involves a reference to an element
if Nkind (Actual) = N_Type_Conversion then
V_Typ := Etype (Expression (Actual));
- Var := Make_Var (Expression (Actual));
- Crep := not Same_Representation
- (Etype (Formal), Etype (Expression (Actual)));
+
+ -- If the formal is an (in-)out parameter, capture the name
+ -- of the variable in order to build the post-call assignment.
+
+ Var := Make_Var (Expression (Actual));
+
+ Crep := not Same_Representation
+ (Etype (Formal), Etype (Expression (Actual)));
+
else
V_Typ := Etype (Actual);
Var := Make_Var (Actual);
Init :=
Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc));
end if;
+
+ elsif Ekind (Formal) = E_In_Parameter then
+ Init := New_Occurrence_Of (Var, Loc);
+
else
Init := Empty;
end if;
Rewrite (N_Node, Make_Null_Statement (Loc));
end if;
- -- If type conversion, use reverse conversion on exit
+ -- For IN parameter, all we do is to replace the actual
- if Nkind (Actual) = N_Type_Conversion then
- if Conversion_OK (Actual) then
- Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
+ if Ekind (Formal) = E_In_Parameter then
+ Rewrite (Actual, New_Reference_To (Temp, Loc));
+ Analyze (Actual);
+
+ -- Processing for OUT or IN OUT parameter
+
+ else
+ -- If type conversion, use reverse conversion on exit
+
+ if Nkind (Actual) = N_Type_Conversion then
+ if Conversion_OK (Actual) then
+ Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
+ else
+ Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
+ end if;
else
- Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
+ Expr := New_Occurrence_Of (Temp, Loc);
end if;
- else
- Expr := New_Occurrence_Of (Temp, Loc);
- end if;
- Rewrite (Actual, New_Reference_To (Temp, Loc));
- Analyze (Actual);
+ Rewrite (Actual, New_Reference_To (Temp, Loc));
+ Analyze (Actual);
- Append_To (Post_Call,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Var, Loc),
- Expression => Expr));
+ Append_To (Post_Call,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Var, Loc),
+ Expression => Expr));
- Set_Assignment_OK (Name (Last (Post_Call)));
+ Set_Assignment_OK (Name (Last (Post_Call)));
+ end if;
end Add_Call_By_Copy_Code;
----------------------------------
---------------------------
procedure Check_Fortran_Logical is
- Logical : Entity_Id := Etype (Formal);
+ Logical : constant Entity_Id := Etype (Formal);
Var : Entity_Id;
-- Note: this is very incomplete, e.g. it does not handle arrays
elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
Add_Call_By_Copy_Code;
+ -- References to possibly unaligned slices of arrays are expanded
+
+ elsif Is_Possibly_Unaligned_Slice (Actual) then
+ Add_Call_By_Copy_Code;
+
-- Deal with access types where the actual subtpe and the
-- formal subtype are not the same, requiring a check.
Add_Call_By_Copy_Code;
elsif Is_Entity_Name (Actual)
- and then Is_Volatile (Entity (Actual))
+ and then Treat_As_Volatile (Entity (Actual))
and then not Is_Scalar_Type (Etype (Entity (Actual)))
- and then not Is_Volatile (E_Formal)
+ and then not Treat_As_Volatile (E_Formal)
then
Add_Call_By_Copy_Code;
Add_Call_By_Copy_Code;
end if;
- -- The only processing required for IN parameters is in the packed
- -- array case, where we expand the indexed component (the circuit
- -- in Exp_Ch4 deliberately left indexed components appearing as
- -- actuals untouched, so that the special processing above for
- -- the OUT and IN OUT cases could be performed. We could make the
- -- test in Exp_Ch4 more complex and have it detect the parameter
- -- mode, but it is easier simply to handle all cases here.
-
- -- Similarly, we have to expand slices of packed arrays here
+ -- Processing for IN parameters
else
+ -- For IN parameters is in the packed array case, we expand an
+ -- indexed component (the circuit in Exp_Ch4 deliberately left
+ -- indexed components appearing as actuals untouched, so that
+ -- the special processing above for the OUT and IN OUT cases
+ -- could be performed. We could make the test in Exp_Ch4 more
+ -- complex and have it detect the parameter mode, but it is
+ -- easier simply to handle all cases here.
+
if Nkind (Actual) = N_Indexed_Component
and then Is_Packed (Etype (Prefix (Actual)))
then
Reset_Packed_Prefix;
Expand_Packed_Element_Reference (Actual);
- elsif Is_Ref_To_Bit_Packed_Array (Actual) then
- Add_Packed_Call_By_Copy_Code;
+ -- If we have a reference to a bit packed array, we copy it,
+ -- since the actual must be byte aligned.
- elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
- declare
- Typ : constant Entity_Id := Etype (Actual);
+ -- Is this really necessary in all cases???
- Ent : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ elsif Is_Ref_To_Bit_Packed_Array (Actual) then
+ Add_Packed_Call_By_Copy_Code;
- Decl : constant Node_Id :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent,
- Object_Definition =>
- New_Occurrence_Of (Typ, Loc));
+ -- Similarly, we have to expand slices of packed arrays here
+ -- because the result must be byte aligned.
- begin
- Set_No_Initialization (Decl);
+ elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
+ Add_Call_By_Copy_Code;
- Insert_Actions (N, New_List (
- Decl,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Ent, Loc),
- Expression => Relocate_Node (Actual))));
+ -- Only processing remaining is to pass by copy if this is a
+ -- reference to a possibly unaligned slice, since the caller
+ -- expects an appropriately aligned argument.
- Rewrite
- (Actual, New_Occurrence_Of (Ent, Loc));
- Analyze_And_Resolve (Actual, Typ);
- end;
+ elsif Is_Possibly_Unaligned_Slice (Actual) then
+ Add_Call_By_Copy_Code;
end if;
end if;
Make_Identifier (Loc, Chars (EF))));
Analyze_And_Resolve (Expr, Etype (EF));
-
end Add_Extra_Actual;
---------------------------
-- original derived type declaration to find the proper parent.
if Nkind (Parent (S)) /= N_Full_Type_Declaration
- or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
- or else Nkind (Type_Definition (Original_Node (Parent (S))))
- /= N_Derived_Type_Definition
+ or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
+ or else Nkind (Type_Definition (Original_Node (Parent (S))))
+ /= N_Derived_Type_Definition
+ or else not In_Instance
then
return Empty;
or else Is_Tagged_Type (Par)
or else Nkind (Parent (Par)) /= N_Subtype_Declaration
or else not In_Open_Scopes (Scope (Par))
- or else not In_Instance
then
return Empty;
Gen_Par := Generic_Parent_Type (Parent (Par));
end if;
+ -- If the generic parent type is still the generic type, this
+ -- is a private formal, not a derived formal, and there are no
+ -- operations inherited from the formal.
+
+ if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
+ return Empty;
+ end if;
+
Gen_Prim := Collect_Primitive_Operations (Gen_Par);
Elmt := First_Elmt (Gen_Prim);
-- Replace call to Raise_Exception by call to Raise_Exception_Always
-- if we can tell that the first parameter cannot possibly be null.
+ -- This helps optimization and also generation of warnings.
- if not Restrictions (No_Exception_Handlers)
+ if not Restriction_Active (No_Exception_Handlers)
and then Is_RTE (Subp, RE_Raise_Exception)
then
declare
end if;
end if;
- -- First step, compute extra actuals, corresponding to any
+ -- First step, compute extra actuals, corresponding to any
-- Extra_Formals present. Note that we do not access Extra_Formals
- -- directly, instead we simply note the presence of the extra
+ -- directly, instead we simply note the presence of the extra
-- formals as we process the regular formals and collect the
-- corresponding actuals in Extra_Actuals.
+ -- We also generate any required range checks for actuals as we go
+ -- through the loop, since this is a convenient place to do this.
+
Formal := First_Formal (Subp);
Actual := First_Actual (N);
-
while Present (Formal) loop
+
+ -- Generate range check if required (not activated yet ???)
+
+-- if Do_Range_Check (Actual) then
+-- Set_Do_Range_Check (Actual, False);
+-- Generate_Range_Check
+-- (Actual, Etype (Formal), CE_Range_Check_Failed);
+-- end if;
+
+ -- Prepare to examine current entry
+
Prev := Actual;
Prev_Orig := Original_Node (Prev);
-- occur as out parameter actuals on calls to stream
-- procedures.
- if Nkind (Act_Prev) = N_Type_Conversion
+ while Nkind (Act_Prev) = N_Type_Conversion
or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion
- then
+ loop
Act_Prev := Expression (Act_Prev);
- end if;
+ end loop;
Add_Extra_Actual (
Make_Attribute_Reference (Sloc (Prev),
- Prefix => Duplicate_Subexpr (Act_Prev, Name_Req => True),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks
+ (Act_Prev, Name_Req => True),
Attribute_Name => Name_Constrained),
Extra_Constrained (Formal));
end;
-- expander-generated actuals and when -gnatdj is set.
if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
- or else Suppress_Accessibility_Checks (Subp)
+ or else Access_Checks_Suppressed (Subp)
then
null;
else
Cond :=
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Prev),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Prev),
Right_Opnd => Make_Null (Loc));
Insert_Action (Prev,
Make_Raise_Constraint_Error (Loc,
Reason => CE_Access_Parameter_Is_Null));
end if;
- -- Perform appropriate validity checks on parameters
+ -- Perform appropriate validity checks on parameters that
+ -- are entities.
if Validity_Checks_On then
-
if Ekind (Formal) = E_In_Parameter
and then Validity_Check_In_Params
then
+ -- If the actual is an indexed component of a packed
+ -- type, it has not been expanded yet. It will be
+ -- copied in the validity code that follows, and has
+ -- to be expanded appropriately, so reanalyze it.
+
+ if Nkind (Actual) = N_Indexed_Component then
+ Set_Analyzed (Actual, False);
+ end if;
+
Ensure_Valid (Actual);
elsif Ekind (Formal) = E_In_Out_Parameter
Check_Valid_Lvalue_Subscripts (Actual);
end if;
+ -- Mark any scalar OUT parameter that is a simple variable
+ -- as no longer known to be valid (unless the type is always
+ -- valid). This reflects the fact that if an OUT parameter
+ -- is never set in a procedure, then it can become invalid
+ -- on return from the procedure.
+
+ if Ekind (Formal) = E_Out_Parameter
+ and then Is_Entity_Name (Actual)
+ and then Ekind (Entity (Actual)) = E_Variable
+ and then not Is_Known_Valid (Etype (Actual))
+ then
+ Set_Is_Known_Valid (Entity (Actual), False);
+ end if;
+
+ -- For an OUT or IN OUT parameter of an access type, if the
+ -- actual is an entity, then it is no longer known to be non-null.
+
+ if Ekind (Formal) /= E_In_Parameter
+ and then Is_Entity_Name (Actual)
+ and then Is_Access_Type (Etype (Actual))
+ then
+ Set_Is_Known_Non_Null (Entity (Actual), False);
+ end if;
+
-- If the formal is class wide and the actual is an aggregate, force
-- evaluation so that the back end who does not know about class-wide
-- type, does not generate a temporary of the wrong size.
Make_Implicit_If_Statement (N,
Condition =>
Make_Op_Not (Loc,
- Get_Remotely_Callable (Duplicate_Subexpr (Actual))),
+ Get_Remotely_Callable
+ (Duplicate_Subexpr_Move_Checks (Actual))),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE
-- If we are expanding a rhs of an assignement we need to check if
-- tag propagation is needed. This code belongs theorically in Analyze
- -- Assignment but has to be done earlier (bottom-up) because the
+ -- Assignment but has to be done earlier (bottom-up) because the
-- assignment might be transformed into a declaration for an uncons-
-- trained value, if the expression is classwide.
if Present (Ass)
and then Is_Class_Wide_Type (Etype (Name (Ass)))
then
- Propagate_Tag (Name (Ass), N);
+ if Etype (N) /= Root_Type (Etype (Name (Ass))) then
+ Error_Msg_NE
+ ("tag-indeterminate expression must have type&"
+ & "('R'M 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
+ else
+ Propagate_Tag (Name (Ass), N);
+ end if;
+
+ -- The call will be rewritten as a dispatching call, and
+ -- expanded as such.
+
return;
end if;
end;
and then not Java_VM
then
Expand_Dispatch_Call (N);
+
+ -- The following return is worrisome. Is it really OK to
+ -- skip all remaining processing in this procedure ???
+
return;
-- Similarly, expand calls to RCI subprograms on which pragma
elsif
Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type
- and then
- Designated_Type (Etype (Parent_Formal))
- /= Designated_Type (Etype (Actual))
+ and then Designated_Type (Etype (Parent_Formal))
+ /=
+ Designated_Type (Etype (Actual))
and then not Is_Controlling_Formal (Formal)
then
-
-- This unchecked conversion is not necessary unless
- -- inlining is unabled, because in that case the type
+ -- inlining is enabled, because in that case the type
-- mismatch may become visible in the body about to be
-- inlined.
Subp := Parent_Subp;
end if;
- -- Some more special cases for cases other than explicit dereference
-
- if Nkind (Name (N)) /= N_Explicit_Dereference then
-
- -- Calls to an enumeration literal are replaced by the literal
- -- This case occurs only when we have a call to a function that
- -- is a renaming of an enumeration literal. The normal case of
- -- a direct reference to an enumeration literal has already been
- -- been dealt with by Resolve_Call. If the function is itself
- -- inherited (see 7423-001) the literal of the parent type must
- -- be explicitly converted to the return type of the function.
+ if Is_RTE (Subp, RE_Abort_Task) then
+ Check_Restriction (No_Abort_Statements, N);
+ end if;
- if Ekind (Subp) = E_Enumeration_Literal then
- if Base_Type (Etype (Subp)) /= Base_Type (Etype (N)) then
- Rewrite
- (N, Convert_To (Etype (N), New_Occurrence_Of (Subp, Loc)));
- else
- Rewrite (N, New_Occurrence_Of (Subp, Loc));
- Resolve (N, Etype (N));
- end if;
- end if;
+ if Nkind (Name (N)) = N_Explicit_Dereference then
-- Handle case of access to protected subprogram type
- else
if Ekind (Base_Type (Etype (Prefix (Name (N))))) =
E_Access_Protected_Subprogram_Type
then
Parm : List_Id;
Nam : Node_Id;
Obj : Node_Id;
- Ptr : Node_Id := Prefix (Name (N));
- T : Entity_Id := Equivalent_Type (Base_Type (Etype (Ptr)));
- D_T : Entity_Id := Designated_Type (Base_Type (Etype (Ptr)));
+ Ptr : constant Node_Id := Prefix (Name (N));
+
+ T : constant Entity_Id :=
+ Equivalent_Type (Base_Type (Etype (Ptr)));
+
+ D_T : constant Entity_Id :=
+ Designated_Type (Base_Type (Etype (Ptr)));
begin
Obj := Make_Selected_Component (Loc,
end if;
Set_First_Named_Actual (Call, First_Named_Actual (N));
-
Set_Etype (Call, Etype (D_T));
-- We do not re-analyze the call to avoid infinite recursion.
then
if Is_Inlined (Subp) then
- declare
- Spec : constant Node_Id := Unit_Declaration_Node (Subp);
+ Inlined_Subprogram : declare
+ Bod : Node_Id;
+ Must_Inline : Boolean := False;
+ Spec : constant Node_Id := Unit_Declaration_Node (Subp);
+ Scop : constant Entity_Id := Scope (Subp);
+
+ function In_Unfrozen_Instance return Boolean;
+ -- If the subprogram comes from an instance in the same
+ -- unit, and the instance is not yet frozen, inlining might
+ -- trigger order-of-elaboration problems in gigi.
+
+ --------------------------
+ -- In_Unfrozen_Instance --
+ --------------------------
+
+ function In_Unfrozen_Instance return Boolean is
+ S : Entity_Id := Scop;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Generic_Instance (S)
+ and then Present (Freeze_Node (S))
+ and then not Analyzed (Freeze_Node (S))
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Unfrozen_Instance;
+
+ -- Start of processing for Inlined_Subprogram
begin
-- Verify that the body to inline has already been seen,
-- does not occur earlier. This avoids order-of-elaboration
-- problems in gigi.
- if Present (Spec)
- and then Nkind (Spec) = N_Subprogram_Declaration
- and then Present (Body_To_Inline (Spec))
- and then (In_Extended_Main_Code_Unit (N)
- or else In_Extended_Main_Code_Unit (Parent (N)))
- and then (not In_Same_Extended_Unit
- (Sloc (Body_To_Inline (Spec)), Loc)
- or else
- Earlier_In_Extended_Unit
- (Sloc (Body_To_Inline (Spec)), Loc))
+ if No (Spec)
+ or else Nkind (Spec) /= N_Subprogram_Declaration
+ or else No (Body_To_Inline (Spec))
then
+ Must_Inline := False;
+
+ -- If this an inherited function that returns a private
+ -- type, do not inline if the full view is an unconstrained
+ -- array, because such calls cannot be inlined.
+
+ elsif Present (Orig_Subp)
+ and then Is_Array_Type (Etype (Orig_Subp))
+ and then not Is_Constrained (Etype (Orig_Subp))
+ then
+ Must_Inline := False;
+
+ elsif In_Unfrozen_Instance then
+ Must_Inline := False;
+
+ else
+ Bod := Body_To_Inline (Spec);
+
+ if (In_Extended_Main_Code_Unit (N)
+ or else In_Extended_Main_Code_Unit (Parent (N))
+ or else Is_Always_Inlined (Subp))
+ and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
+ or else
+ Earlier_In_Extended_Unit (Sloc (Bod), Loc))
+ then
+ Must_Inline := True;
+
+ -- If we are compiling a package body that is not the main
+ -- unit, it must be for inlining/instantiation purposes,
+ -- in which case we inline the call to insure that the same
+ -- temporaries are generated when compiling the body by
+ -- itself. Otherwise link errors can occur.
+
+ elsif not (In_Extended_Main_Code_Unit (N))
+ and then In_Package_Body
+ then
+ Must_Inline := True;
+ end if;
+ end if;
+
+ if Must_Inline then
Expand_Inlined_Call (N, Subp, Orig_Subp);
else
- -- Let the back-end handle it.
+ -- Let the back end handle it
Add_Inlined_Body (Subp);
and then No (Body_To_Inline (Spec))
and then not Has_Completion (Subp)
and then In_Same_Extended_Unit (Sloc (Spec), Loc)
- and then Ineffective_Inline_Warnings
then
- Error_Msg_N
- ("call cannot be inlined before body is seen?", N);
+ Cannot_Inline
+ ("cannot inline& (body not seen yet)?",
+ N, Subp);
end if;
end if;
- end;
+ end Inlined_Subprogram;
end if;
end if;
Next_Actual (Actual);
end loop;
- -- Now we have Formal and Actual pointing to the first
- -- potentially droppable argument. We can drop all the
- -- trailing arguments whose actual matches the default.
- -- Note that we know that all remaining formals have
- -- defaults, because we checked that this requirement
- -- was met before setting First_Optional_Parameter.
+ -- We have Formal and Actual pointing to the first potentially
+ -- droppable argument. We can drop all the trailing arguments
+ -- whose actual matches the default. Note that we know that all
+ -- remaining formals have defaults, because we checked that this
+ -- requirement was met before setting First_Optional_Parameter.
-- We use Fully_Conformant_Expressions to check for identity
-- between formals and actuals, which may miss some cases, but
declare
Temp : Node_Id;
Passoc : Node_Id;
- Junk : Node_Id;
+
+ Discard : Node_Id;
+ pragma Warnings (Off, Discard);
begin
-- First step, remove all the named parameters from the
end loop;
while Present (Next (Temp)) loop
- Junk := Remove_Next (Temp);
+ Discard := Remove_Next (Temp);
end loop;
end if;
end if;
end;
end if;
-
end Expand_Call;
--------------------------
Subp : Entity_Id;
Orig_Subp : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Is_Predef : constant Boolean :=
+ Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Subp)));
+ Orig_Bod : constant Node_Id :=
+ Body_To_Inline (Unit_Declaration_Node (Subp));
+
Blk : Node_Id;
Bod : Node_Id;
Decl : Node_Id;
Lab_Id : Node_Id;
New_A : Node_Id;
Num_Ret : Int := 0;
- Orig_Bod : constant Node_Id :=
- Body_To_Inline (Unit_Declaration_Node (Subp));
Ret_Type : Entity_Id;
Targ : Node_Id;
Temp : Entity_Id;
-- Replace occurrence of a formal with the corresponding actual, or
-- the thunk generated for it.
+ function Process_Sloc (Nod : Node_Id) return Traverse_Result;
+ -- If the call being expanded is that of an internal subprogram,
+ -- set the sloc of the generated block to that of the call itself,
+ -- so that the expansion is skipped by the -next- command in gdb.
+ -- Same processing for a subprogram in a predefined file, e.g.
+ -- Ada.Tags. If Debug_Generated_Code is true, suppress this change
+ -- to simplify our own development.
+
procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
-- If the function body is a single expression, replace call with
-- expression, else insert block appropriately.
if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
then
- -- function body is a single expression. No need for
+ -- Function body is a single expression. No need for
-- exit label.
+
null;
else
return OK;
+ -- Remove pragma Unreferenced since it may refer to formals that
+ -- are not visible in the inlined body, and in any case we will
+ -- not be posting warnings on the inlined body so it is unneeded.
+
+ elsif Nkind (N) = N_Pragma
+ and then Chars (N) = Name_Unreferenced
+ then
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ return OK;
+
else
return OK;
end if;
procedure Replace_Formals is new Traverse_Proc (Process_Formals);
+ ------------------
+ -- Process_Sloc --
+ ------------------
+
+ function Process_Sloc (Nod : Node_Id) return Traverse_Result is
+ begin
+ if not Debug_Generated_Code then
+ Set_Sloc (Nod, Sloc (N));
+ Set_Comes_From_Source (Nod, False);
+ end if;
+
+ return OK;
+ end Process_Sloc;
+
+ procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
+
---------------------------
-- Rewrite_Function_Call --
---------------------------
procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
- HSS : Node_Id := Handled_Statement_Sequence (Blk);
- Fst : Node_Id := First (Statements (HSS));
+ HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
+ Fst : constant Node_Id := First (Statements (HSS));
begin
-
-- Optimize simple case: function body is a single return statement,
-- which has been expanded into an assignment.
and then Is_Entity_Name (Name (Parent (N)))
then
- -- replace assignment with the block.
+ -- Replace assignment with the block
Rewrite (Parent (N), Blk);
----------------------------
procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
- HSS : Node_Id := Handled_Statement_Sequence (Blk);
+ HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
begin
if Is_Empty_List (Declarations (Blk)) then
-- Start of processing for Expand_Inlined_Call
begin
+ -- Check for special case of To_Address call, and if so, just
+ -- do an unchecked conversion instead of expanding the call.
+ -- Not only is this more efficient, but it also avoids a
+ -- problem with order of elaboration when address clauses
+ -- are inlined (address expr elaborated at wrong point).
+
+ if Subp = RTE (RE_To_Address) then
+ Rewrite (N,
+ Unchecked_Convert_To
+ (RTE (RE_Address),
+ Relocate_Node (First_Actual (N))));
+ return;
+ end if;
+
if Nkind (Orig_Bod) = N_Defining_Identifier then
-- Subprogram is a renaming_as_body. Calls appearing after the
-- that nested inlined calls appear in the main unit.
Save_Env (Subp, Empty);
- Set_Copied_Sloc (N, Defining_Entity (Orig_Bod));
-
- Bod :=
- Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
+ Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
+ Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
Blk :=
Make_Block_Statement (Loc,
Declarations => Declarations (Bod),
-- are scalars and require copying to preserve semantics.
while Present (F) loop
-
if Present (Renamed_Object (F)) then
Error_Msg_N (" cannot inline call to recursive subprogram", N);
return;
Temp_Typ := Etype (A);
end if;
- if (not Is_Entity_Name (A)
- and then Nkind (A) /= N_Integer_Literal
- and then Nkind (A) /= N_Real_Literal)
+ -- If the actual is a simple name or a literal, no need to
+ -- create a temporary, object can be used directly.
+
+ if (Is_Entity_Name (A)
+ and then
+ (not Is_Scalar_Type (Etype (A))
+ or else Ekind (Entity (A)) = E_Enumeration_Literal))
- or else Is_Scalar_Type (Etype (A))
+ or else Nkind (A) = N_Real_Literal
+ or else Nkind (A) = N_Integer_Literal
+ or else Nkind (A) = N_Character_Literal
then
+ if Etype (F) /= Etype (A) then
+ Set_Renamed_Object
+ (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
+ else
+ Set_Renamed_Object (F, A);
+ end if;
+
+ else
Temp :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('C'));
-- If the actual for an in/in-out parameter is a view conversion,
-- make it into an unchecked conversion, given that an untagged
-- type conversion is not a proper object for a renaming.
+
-- In-out conversions that involve real conversions have already
-- been transformed in Expand_Actuals.
if Nkind (A) = N_Type_Conversion
- and then
- (Ekind (F) = E_In_Out_Parameter
- or else not Is_Tagged_Type (Etype (F)))
+ and then Ekind (F) /= E_In_Parameter
then
New_A := Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
Prepend (Decl, Declarations (Blk));
Set_Renamed_Object (F, Temp);
-
- else
- if Etype (F) /= Etype (A) then
- Set_Renamed_Object
- (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
- else
- Set_Renamed_Object (F, A);
- end if;
end if;
Next_Formal (F);
Replace_Formals (Blk);
Set_Parent (Blk, N);
+ if not Comes_From_Source (Subp)
+ or else Is_Predef
+ then
+ Reset_Slocs (Blk);
+ end if;
+
if Present (Exit_Lab) then
-- If the body was a single expression, the single return statement
end if;
-- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
- -- conflicting private views that Gigi would ignore.
+ -- conflicting private views that Gigi would ignore. If this is a
+ -- predefined unit, analyze with checks off, as is done in the non-
+ -- inlined run-time units.
declare
I_Flag : constant Boolean := In_Inlined_Body;
begin
In_Inlined_Body := True;
- Analyze (Blk);
+
+ if Is_Predef then
+ declare
+ Style : constant Boolean := Style_Check;
+ begin
+ Style_Check := False;
+ Analyze (Blk, Suppress => All_Checks);
+ Style_Check := Style;
+ end;
+
+ else
+ Analyze (Blk);
+ end if;
+
In_Inlined_Body := I_Flag;
end;
Typ : constant Entity_Id := Etype (N);
function Returned_By_Reference return Boolean;
- -- If the return type is returned through the secondary stack. i.e.
- -- by reference, we don't want to create a temporary to force stack
- -- checking.
+ -- If the return type is returned through the secondary stack. that is
+ -- by reference, we don't want to create a temp to force stack checking.
function Returned_By_Reference return Boolean is
S : Entity_Id := Current_Scope;
if May_Generate_Large_Temp (Typ)
and then Nkind (Parent (N)) /= N_Assignment_Statement
and then
+ (Nkind (Parent (N)) /= N_Qualified_Expression
+ or else Nkind (Parent (Parent (N))) /= N_Assignment_Statement)
+ and then
(Nkind (Parent (N)) /= N_Object_Declaration
or else Expression (Parent (N)) /= N)
and then not Returned_By_Reference
declare
Loc : constant Source_Ptr := Sloc (N);
- Temp_Obj : constant Entity_Id := Make_Defining_Identifier (Loc,
- New_Internal_Name ('F'));
+ Temp_Obj : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('F'));
Temp_Typ : Entity_Id := Typ;
Decl : Node_Id;
A : Node_Id;
-- Reset Pure indication if any parameter has root type System.Address
+ -- Wrap thread body
+
procedure Expand_N_Subprogram_Body (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
H : constant Node_Id := Handled_Statement_Sequence (N);
-- the latter test is not critical, it does not matter if we add a
-- few extra returns, since they get eliminated anyway later on.
+ procedure Expand_Thread_Body;
+ -- Perform required expansion of a thread body
+
----------------
-- Add_Return --
----------------
procedure Add_Return (S : List_Id) is
- Last_S : constant Node_Id := Last (S);
- -- Get original node, in case raise has been rewritten
-
begin
- if not Is_Transfer (Last_S) then
- Append_To (S, Make_Return_Statement (Sloc (Last_S)));
+ if not Is_Transfer (Last (S)) then
+
+ -- The source location for the return is the end label
+ -- of the procedure in all cases. This is a bit odd when
+ -- there are exception handlers, but not much else we can do.
+
+ Append_To (S, Make_Return_Statement (Sloc (End_Label (H))));
end if;
end Add_Return;
+ ------------------------
+ -- Expand_Thread_Body --
+ ------------------------
+
+ -- The required expansion of a thread body is as follows
+
+ -- procedure <thread body procedure name> is
+
+ -- _Secondary_Stack : aliased
+ -- Storage_Elements.Storage_Array
+ -- (1 .. Storage_Offset (Sec_Stack_Size));
+ -- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
+
+ -- _Process_ATSD : aliased System.Threads.ATSD;
+
+ -- begin
+ -- System.Threads.Thread_Body_Enter;
+ -- (_Secondary_Stack'Address,
+ -- _Secondary_Stack'Length,
+ -- _Process_ATSD'Address);
+
+ -- declare
+ -- <user declarations>
+ -- begin
+ -- <user statements>
+ -- <user exception handlers>
+ -- end;
+
+ -- System.Threads.Thread_Body_Leave;
+
+ -- exception
+ -- when E : others =>
+ -- System.Threads.Thread_Body_Exceptional_Exit (E);
+ -- end;
+
+ -- Note the exception handler is omitted if pragma Restriction
+ -- No_Exception_Handlers is currently active.
+
+ procedure Expand_Thread_Body is
+ User_Decls : constant List_Id := Declarations (N);
+ Sec_Stack_Len : Node_Id;
+
+ TB_Pragma : constant Node_Id :=
+ Get_Rep_Pragma (Spec_Id, Name_Thread_Body);
+
+ Ent_SS : Entity_Id;
+ Ent_ATSD : Entity_Id;
+ Ent_EO : Entity_Id;
+
+ Decl_SS : Node_Id;
+ Decl_ATSD : Node_Id;
+
+ Excep_Handlers : List_Id;
+
+ begin
+ New_Scope (Spec_Id);
+
+ -- Get proper setting for secondary stack size
+
+ if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then
+ Sec_Stack_Len :=
+ Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
+ else
+ Sec_Stack_Len :=
+ New_Occurrence_Of (RTE (RE_Default_Secondary_Stack_Size), Loc);
+ end if;
+
+ Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
+
+ -- Build and set declarations for the wrapped thread body
+
+ Ent_SS := Make_Defining_Identifier (Loc, Name_uSecondary_Stack);
+ Ent_ATSD := Make_Defining_Identifier (Loc, Name_uProcess_ATSD);
+
+ Decl_SS :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent_SS,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Sec_Stack_Len)))));
+
+ Decl_ATSD :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent_ATSD,
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (RTE (RE_ATSD), Loc));
+
+ Set_Declarations (N, New_List (Decl_SS, Decl_ATSD));
+ Analyze (Decl_SS);
+ Analyze (Decl_ATSD);
+ Set_Alignment (Ent_SS, UI_From_Int (Maximum_Alignment));
+
+ -- Create new exception handler
+
+ if Restriction_Active (No_Exception_Handlers) then
+ Excep_Handlers := No_List;
+
+ else
+ Check_Restriction (No_Exception_Handlers, N);
+
+ Ent_EO := Make_Defining_Identifier (Loc, Name_uE);
+
+ Excep_Handlers := New_List (
+ Make_Exception_Handler (Loc,
+ Choice_Parameter => Ent_EO,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Thread_Body_Exceptional_Exit), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Ent_EO, Loc))))));
+ end if;
+
+ -- Now build new handled statement sequence and analyze it
+
+ Set_Handled_Statement_Sequence (N,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Thread_Body_Enter), Loc),
+ Parameter_Associations => New_List (
+
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent_SS, Loc),
+ Attribute_Name => Name_Address),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent_SS, Loc),
+ Attribute_Name => Name_Length),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ent_ATSD, Loc),
+ Attribute_Name => Name_Address))),
+
+ Make_Block_Statement (Loc,
+ Declarations => User_Decls,
+ Handled_Statement_Sequence => H),
+
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Thread_Body_Leave), Loc))),
+
+ Exception_Handlers => Excep_Handlers));
+
+ Analyze (Handled_Statement_Sequence (N));
+ End_Scope;
+ end Expand_Thread_Body;
+
-- Start of processing for Expand_N_Subprogram_Body
begin
-- If this is a Pure function which has any parameters whose root
-- type is System.Address, reset the Pure indication, since it will
- -- likely cause incorrect code to be generated.
+ -- likely cause incorrect code to be generated as the parameter is
+ -- probably a pointer, and the fact that the same pointer is passed
+ -- does not mean that the same value is being referenced.
+
+ -- Note that if the programmer gave an explicit Pure_Function pragma,
+ -- then we believe the programmer, and leave the subprogram Pure.
+
+ -- This code should probably be at the freeze point, so that it
+ -- happens even on a -gnatc (or more importantly -gnatt) compile
+ -- so that the semantic tree has Is_Pure set properly ???
if Is_Pure (Spec_Id)
and then Is_Subprogram (Spec_Id)
end;
end if;
+ -- Deal with thread body
+
+ if Is_Thread_Body (Spec_Id) then
+ Expand_Thread_Body;
+ end if;
+
-- If the subprogram does not have pending instantiations, then we
-- must generate the subprogram descriptor now, since the code for
-- the subprogram is complete, and this is our last chance. However
Expand_N_Subprogram_Body (
Unit_Declaration_Node (Corresponding_Body (N)));
end if;
-
end Expand_N_Subprogram_Body_Stub;
-------------------------------------
-- Expand_N_Subprogram_Declaration --
-------------------------------------
- -- The first task to be performed is the construction of default
- -- expression functions for in parameters with default values. These
- -- are parameterless inlined functions that are used to evaluate
- -- default expressions that are more complicated than simple literals
- -- or identifiers referencing constants and variables.
-
-- If the declaration appears within a protected body, it is a private
-- operation of the protected type. We must create the corresponding
-- protected subprogram an associated formals. For a normal protected
-- operation, this is done when expanding the protected type declaration.
procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Subp : Entity_Id := Defining_Entity (N);
- Scop : Entity_Id := Scope (Subp);
- Prot_Sub : Entity_Id;
- Prot_Bod : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Subp : constant Entity_Id := Defining_Entity (N);
+ Scop : constant Entity_Id := Scope (Subp);
+ Prot_Decl : Node_Id;
+ Prot_Bod : Node_Id;
+ Prot_Id : Entity_Id;
begin
-- Deal with case of protected subprogram
and then Is_Protected_Type (Scop)
then
if No (Protected_Body_Subprogram (Subp)) then
- Prot_Sub :=
+ Prot_Decl :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
-- The protected subprogram is declared outside of the protected
-- body. Given that the body has frozen all entities so far, we
- -- freeze the subprogram explicitly. If the body is a subunit,
- -- the insertion point is before the stub in the parent.
+ -- analyze the subprogram and perform freezing actions explicitly.
+ -- If the body is a subunit, the insertion point is before the
+ -- stub in the parent.
Prot_Bod := Parent (List_Containing (N));
Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
end if;
- Insert_Before (Prot_Bod, Prot_Sub);
+ Insert_Before (Prot_Bod, Prot_Decl);
+ Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
New_Scope (Scope (Scop));
- Analyze (Prot_Sub);
- Set_Protected_Body_Subprogram (Subp,
- Defining_Unit_Name (Specification (Prot_Sub)));
+ Analyze (Prot_Decl);
+ Create_Extra_Formals (Prot_Id);
+ Set_Protected_Body_Subprogram (Subp, Prot_Id);
Pop_Scope;
end if;
end if;
declare
Decls : List_Id;
- Obj_Ptr : Entity_Id := Make_Defining_Identifier
- (Loc, New_Internal_Name ('T'));
+ Obj_Ptr : constant Entity_Id := Make_Defining_Identifier (Loc,
+ Chars =>
+ New_Internal_Name ('T'));
+
begin
Decls := New_List (
Make_Full_Type_Declaration (Loc,
Set_Returns_By_Ref (E);
end if;
end;
-
end Freeze_Subprogram;
end Exp_Ch6;
OSDN Git Service
