end if;
end New_Value;
+ -- Local variables
+
+ New_Node : Node_Id;
+ SCIL_Node : Node_Id;
+
-- Start of processing for Expand_Dispatching_Call
begin
Typ := Non_Limited_View (Typ);
end if;
+ -- Generate the SCIL node for this dispatching call. The SCIL node for a
+ -- dispatching call is inserted in the tree before the call is rewriten
+ -- and expanded because the SCIL node must be found by the SCIL backend
+ -- BEFORE the expanded nodes associated with the call node are found.
+
+ if Generate_SCIL then
+ SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
+ Set_SCIL_Related_Node (SCIL_Node, Call_Node);
+ Set_SCIL_Entity (SCIL_Node, Typ);
+ Set_SCIL_Target_Prim (SCIL_Node, Subp);
+ Insert_Action (Call_Node, SCIL_Node);
+ end if;
+
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
Append_To (New_Params,
Duplicate_Subexpr_Move_Checks (Param));
- else
+ elsif Nkind (Parent (Param)) /= N_Parameter_Association
+ or else not Is_Accessibility_Actual (Parent (Param))
+ then
Append_To (New_Params, Relocate_Node (Param));
end if;
else
Controlling_Tag :=
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
+ Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
end if;
if Is_Predefined_Dispatching_Operation (Subp)
or else Is_Predefined_Dispatching_Alias (Subp)
then
- New_Call_Name :=
- Unchecked_Convert_To (Subp_Ptr_Typ,
- Build_Get_Predefined_Prim_Op_Address (Loc,
- Tag_Node => Controlling_Tag,
- Position => DT_Position (Subp)));
+ Build_Get_Predefined_Prim_Op_Address (Loc,
+ Tag_Node => Controlling_Tag,
+ Position => DT_Position (Subp),
+ New_Node => New_Node);
-- Handle dispatching calls to user-defined primitives
else
- New_Call_Name :=
- Unchecked_Convert_To (Subp_Ptr_Typ,
- Build_Get_Prim_Op_Address (Loc,
- Typ => Find_Dispatching_Type (Subp),
- Tag_Node => Controlling_Tag,
- Position => DT_Position (Subp)));
+ Build_Get_Prim_Op_Address (Loc,
+ Typ => Find_Dispatching_Type (Subp),
+ Tag_Node => Controlling_Tag,
+ Position => DT_Position (Subp),
+ New_Node => New_Node);
end if;
- if Nkind (Call_Node) = N_Function_Call then
+ New_Call_Name :=
+ Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
+
+ -- Complete decoration of SCIL dispatching node. It must be done after
+ -- the new call name is built to reference the nodes that will see the
+ -- SCIL backend (because Build_Get_Prim_Op_Address generates an
+ -- unchecked type conversion which relocates the controlling tag node).
+
+ if Generate_SCIL then
+
+ -- Common case: the controlling tag is the tag of an object
+ -- (for example, obj.tag)
+
+ if Nkind (Controlling_Tag) = N_Selected_Component then
+ Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
+
+ -- Handle renaming of selected component
+
+ elsif Nkind (Controlling_Tag) = N_Identifier
+ and then Nkind (Parent (Entity (Controlling_Tag))) =
+ N_Object_Renaming_Declaration
+ and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
+ N_Selected_Component
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Name (Parent (Entity (Controlling_Tag))));
+
+ -- If the controlling tag is an identifier, the SCIL node references
+ -- the corresponding object or parameter declaration
+
+ elsif Nkind (Controlling_Tag) = N_Identifier
+ and then Nkind_In (Parent (Entity (Controlling_Tag)),
+ N_Object_Declaration,
+ N_Parameter_Specification)
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent (Entity (Controlling_Tag)));
+ -- If the controlling tag is a dereference, the SCIL node references
+ -- the corresponding object or parameter declaration
+
+ elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
+ and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
+ and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
+ N_Object_Declaration,
+ N_Parameter_Specification)
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent (Entity (Prefix (Controlling_Tag))));
+
+ -- For a direct reference of the tag of the type the SCIL node
+ -- references the the internal object declaration containing the tag
+ -- of the type.
+
+ elsif Nkind (Controlling_Tag) = N_Attribute_Reference
+ and then Attribute_Name (Controlling_Tag) = Name_Tag
+ then
+ Set_SCIL_Controlling_Tag (SCIL_Node,
+ Parent
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
+
+ -- Interfaces are not supported. For now we leave the SCIL node
+ -- decorated with the Controlling_Tag. More work needed here???
+
+ elsif Is_Interface (Etype (Controlling_Tag)) then
+ Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+ end if;
+
+ if Nkind (Call_Node) = N_Function_Call then
New_Call :=
Make_Function_Call (Loc,
- Name => New_Call_Name,
+ Name => New_Call_Name,
Parameter_Associations => New_Params);
-- If this is a dispatching "=", we must first compare the tags so
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
- Prefix => New_Value (Param),
+ Prefix => New_Value (Param),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ),
Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To (Typ,
New_Value (Next_Actual (Param))),
Selector_Name =>
- New_Reference_To (First_Tag_Component (Typ),
- Loc))),
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
end if;
else
New_Call :=
Make_Procedure_Call_Statement (Loc,
- Name => New_Call_Name,
+ Name => New_Call_Name,
Parameter_Associations => New_Params);
end if;
Thunk_Id : out Entity_Id;
Thunk_Code : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Prim);
- Actuals : constant List_Id := New_List;
- Decl : constant List_Id := New_List;
- Formals : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Prim);
+ Actuals : constant List_Id := New_List;
+ Decl : constant List_Id := New_List;
+ Formals : constant List_Id := New_List;
+ Target : constant Entity_Id := Ultimate_Alias (Prim);
Controlling_Typ : Entity_Id;
Decl_1 : Node_Id;
Decl_2 : Node_Id;
+ Expr : Node_Id;
Formal : Node_Id;
+ Ftyp : Entity_Id;
+ Iface_Formal : Node_Id;
New_Arg : Node_Id;
Offset_To_Top : Node_Id;
- Target : Entity_Id;
Target_Formal : Entity_Id;
begin
Thunk_Id := Empty;
Thunk_Code := Empty;
- -- Traverse the list of alias to find the final target
-
- Target := Prim;
- while Present (Alias (Target)) loop
- Target := Alias (Target);
- end loop;
-
- -- In case of primitives that are functions without formals and
- -- a controlling result there is no need to build the thunk.
+ -- In case of primitives that are functions without formals and a
+ -- controlling result there is no need to build the thunk.
if not Present (First_Formal (Target)) then
pragma Assert (Ekind (Target) = E_Function
return;
end if;
- -- Duplicate the formals
+ -- Duplicate the formals of the Target primitive. In the thunk, the type
+ -- of the controlling formal is the covered interface type (instead of
+ -- the target tagged type). Done to avoid problems with discriminated
+ -- tagged types because, if the controlling type has discriminants with
+ -- default values, then the type conversions done inside the body of
+ -- the thunk (after the displacement of the pointer to the base of the
+ -- actual object) generate code that modify its contents.
+
+ -- Note: This special management is not done for predefined primitives
+ -- because???
+
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Iface_Formal := First_Formal (Interface_Alias (Prim));
+ end if;
Formal := First_Formal (Target);
while Present (Formal) loop
+ Ftyp := Etype (Formal);
+
+ -- Use the interface type as the type of the controlling formal (see
+ -- comment above).
+
+ if not Is_Controlling_Formal (Formal)
+ or else Is_Predefined_Dispatching_Operation (Prim)
+ then
+ Ftyp := Etype (Formal);
+ Expr := New_Copy_Tree (Expression (Parent (Formal)));
+ else
+ Ftyp := Etype (Iface_Formal);
+ Expr := Empty;
+ end if;
+
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Chars => Chars (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
- Parameter_Type =>
- New_Reference_To (Etype (Formal), Loc),
- Expression => New_Copy_Tree (Expression (Parent (Formal)))));
+ Parameter_Type => New_Reference_To (Ftyp, Loc),
+ Expression => Expr));
+
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Next_Formal (Iface_Formal);
+ end if;
Next_Formal (Formal);
end loop;
Target_Formal := First_Formal (Target);
Formal := First (Formals);
while Present (Formal) loop
+
+ -- Handle concurrent types
+
if Ekind (Target_Formal) = E_In_Parameter
and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
- and then Directly_Designated_Type (Etype (Target_Formal))
- = Controlling_Typ
then
- -- Generate:
+ Ftyp := Directly_Designated_Type (Etype (Target_Formal));
+ else
+ Ftyp := Etype (Target_Formal);
+ end if;
+ if Is_Concurrent_Type (Ftyp) then
+ Ftyp := Corresponding_Record_Type (Ftyp);
+ end if;
+
+ if Ekind (Target_Formal) = E_In_Parameter
+ and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
+ and then Ftyp = Controlling_Typ
+ then
+ -- Generate:
-- type T is access all <<type of the target formal>>
-- S : Storage_Offset := Storage_Offset!(Formal)
-- - Offset_To_Top (address!(Formal))
Null_Exclusion_Present => False,
Constant_Present => False,
Subtype_Indication =>
- New_Reference_To
- (Directly_Designated_Type
- (Etype (Target_Formal)), Loc)));
+ New_Reference_To (Ftyp, Loc)));
New_Arg :=
Unchecked_Convert_To (RTE (RE_Address),
(Defining_Identifier (Decl_2),
New_Reference_To (Defining_Identifier (Decl_1), Loc)));
- elsif Etype (Target_Formal) = Controlling_Typ then
- -- Generate:
+ elsif Ftyp = Controlling_Typ then
+ -- Generate:
-- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
-- - Offset_To_Top (Formal'Address)
-- S2 : Addr_Ptr := Addr_Ptr!(S1)
-- Target_Formal (S2.all)
Append_To (Actuals,
- Unchecked_Convert_To
- (Etype (Target_Formal),
+ Unchecked_Convert_To (Ftyp,
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Decl_2), Loc))));
Set_Is_Thunk (Thunk_Id);
+ -- Procedure case
+
if Ekind (Target) = E_Procedure then
Thunk_Code :=
Make_Subprogram_Body (Loc,
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals))));
- else pragma Assert (Ekind (Target) = E_Function);
+ -- Function case
+ else pragma Assert (Ekind (Target) = E_Function);
Thunk_Code :=
Make_Subprogram_Body (Loc,
Specification =>
return False;
end Is_Predefined_Dispatching_Operation;
+ ---------------------------------------
+ -- Is_Predefined_Internal_Operation --
+ ---------------------------------------
+
+ function Is_Predefined_Internal_Operation
+ (E : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ if not Is_Dispatching_Operation (E) then
+ return False;
+ end if;
+
+ Get_Name_String (Chars (E));
+
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Chars (E) = Name_uSize
+ or else Chars (E) = Name_uAlignment
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ or else Chars (E) = Name_uAssign
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Internal_Operation;
+
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
New_Reference_To
(RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
+ -- Generate a SCIL node for the previous object declaration
+ -- because it has a null dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
(RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
-- Generate:
-- DT : Dispatch_Table_Wrapper (Nb_Prim);
-- for DT'Alignment use Address'Alignment;
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List))));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it contains a dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier =>
exit when Parent_Typ = Current_Typ;
- if Is_CPP_Class (Parent_Typ)
- or else Is_Interface (Typ)
- then
+ if Is_CPP_Class (Parent_Typ) then
+
-- The tags defined in the C++ side will be inherited when
-- the object is constructed (Exp_Ch3.Build_Init_Procedure)
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a null dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it contains a dispatch table.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
Tname : constant Name_Id := Chars (Typ);
AI_Tag_Comp : Elmt_Id;
- DT : Node_Id;
+ DT : Node_Id := Empty;
DT_Ptr : Node_Id;
Predef_Prims_Ptr : Node_Id;
- Iface_DT : Node_Id;
+ Iface_DT : Node_Id := Empty;
Iface_DT_Ptr : Node_Id;
+ New_Node : Node_Id;
Suffix_Index : Int;
Typ_Name : Name_Id;
Typ_Comps : Elist_Id;
(RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
+
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims_Ptr,
New_Occurrence_Of
(RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
+
+ -- Generate the SCIL node for the previous object declaration
+ -- because it has a tag initialization.
+
+ if Generate_SCIL then
+ New_Node :=
+ Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result)));
+ Set_SCIL_Related_Node (New_Node, Last (Result));
+ Set_SCIL_Entity (New_Node, Typ);
+ Insert_Before (Last (Result), New_Node);
+ end if;
end if;
Set_Is_True_Constant (DT_Ptr);
end;
end if;
+ -- Mark entities of dispatch table. Required by the back end to
+ -- handle them properly.
+
+ if Present (DT) then
+ Set_Is_Dispatch_Table_Entity (DT);
+ Set_Is_Dispatch_Table_Entity (Etype (DT));
+ end if;
+
+ if Present (Iface_DT) then
+ Set_Is_Dispatch_Table_Entity (Iface_DT);
+ Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
+ end if;
+
Set_Ekind (DT_Ptr, E_Constant);
Set_Is_Tag (DT_Ptr);
Set_Related_Type (DT_Ptr, Typ);
Res : constant Node_Id := Duplicate_Subexpr (From);
begin
if Is_Access_Type (Etype (From)) then
- return Make_Explicit_Dereference (Sloc (From),
- Prefix => Res);
+ return
+ Make_Explicit_Dereference (Sloc (From),
+ Prefix => Res);
else
return Res;
end if;
begin
pragma Assert (Present (First_Tag_Component (Typ)));
- -- Set the DT_Position for each primitive operation. Perform some
- -- sanity checks to avoid to build completely inconsistent dispatch
- -- tables.
+ -- Set the DT_Position for each primitive operation. Perform some sanity
+ -- checks to avoid building inconsistent dispatch tables.
- -- First stage: Set the DTC entity of all the primitive operations
- -- This is required to properly read the DT_Position attribute in
- -- the latter stages.
+ -- First stage: Set the DTC entity of all the primitive operations. This
+ -- is required to properly read the DT_Position attribute in the latter
+ -- stages.
Prim_Elmt := First_Prim;
Count_Prim := 0;
-- Predefined primitives have a separate dispatch table
if not (Is_Predefined_Dispatching_Operation (Prim)
- or else Is_Predefined_Dispatching_Alias (Prim))
+ or else
+ Is_Predefined_Dispatching_Alias (Prim))
then
Count_Prim := Count_Prim + 1;
end if;
OSDN Git Service
