-- Iir to ortho translator.
-- Copyright (C) 2002 - 2014 Tristan Gingold
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 2 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <gnu.org/licenses>.
with Vhdl.Errors; use Vhdl.Errors;
with Files_Map;
with Vhdl.Utils; use Vhdl.Utils;
with Vhdl.Std_Package; use Vhdl.Std_Package;
with Vhdl.Canon;
with Translation; use Translation;
with Trans.Chap2;
with Trans.Chap3;
with Trans.Chap5;
with Trans.Chap6;
with Trans.Chap7;
with Trans.Chap8;
with Trans.Chap9;
with Trans.Chap14;
with Trans.Rtis;
with Trans.Helpers2; use Trans.Helpers2;
with Trans_Decls; use Trans_Decls;
with Trans.Foreach_Non_Composite;
package body Trans.Chap4 is
use Trans.Helpers;
-- Get the ortho type for an object of mode MODE.
function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type)
return O_Tnode is
begin
case Tinfo.Type_Mode is
when Type_Mode_Complex_Record
| Type_Mode_Complex_Array
| Type_Mode_Protected =>
-- For a complex type, use a pointer.
return Tinfo.Ortho_Ptr_Type (Kind);
when others =>
return Tinfo.Ortho_Type (Kind);
end case;
end Get_Object_Type;
-- Return the pointer type for Tinfo.
-- For a fat array, this is the fat pointer to slightly optimize accesses.
function Get_Object_Ptr_Type
(Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) return O_Tnode is
begin
if Tinfo.Type_Mode in Type_Mode_Unbounded then
-- Fat pointers are already pointers, no need to create an
-- additional indirection.
return Tinfo.Ortho_Type (Kind);
else
if Kind = Mode_Signal
and then Tinfo.Type_Mode in Type_Mode_Scalar
then
-- A scalar signal is already a pointer.
return Tinfo.Ortho_Type (Kind);
else
return Tinfo.Ortho_Ptr_Type (Kind);
end if;
end if;
end Get_Object_Ptr_Type;
function Lop2M
(Obj_Ptr : O_Lnode; Tinfo : Type_Info_Acc; Mode : Object_Kind_Type)
return Mnode is
begin
if (Mode = Mode_Signal
and then Tinfo.Type_Mode in Type_Mode_Scalar)
or else Tinfo.Type_Mode in Type_Mode_Unbounded
then
return Lv2M (Obj_Ptr, Tinfo, Mode);
else
return Lp2M (Obj_Ptr, Tinfo, Mode);
end if;
end Lop2M;
procedure Assign_Obj_Ptr (Dest : Mnode; Src : Mnode)
is
Mode : constant Object_Kind_Type := Get_Object_Kind (Dest);
Tinfo : constant Type_Info_Acc := Get_Type_Info (Dest);
begin
pragma Assert (Mode = Get_Object_Kind (Src));
pragma Assert (Tinfo.Type_Mode = Get_Type_Info (Src).Type_Mode);
if Tinfo.Type_Mode in Type_Mode_Unbounded then
Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src));
else
if Mode = Mode_Signal
and then Tinfo.Type_Mode in Type_Mode_Scalar
then
New_Assign_Stmt (M2Lv (Dest), M2E (Src));
else
New_Assign_Stmt (M2Lp (Dest), M2Addr (Src));
end if;
end if;
end Assign_Obj_Ptr;
procedure Create_Object (El : Iir)
is
Obj_Type : O_Tnode;
Info : Object_Info_Acc;
Tinfo : Type_Info_Acc;
Def : Iir;
Val : constant Iir := Get_Default_Value (El);
Storage : O_Storage;
Deferred : Iir;
begin
-- Be sure the object type was translated.
if Get_Kind (El) = Iir_Kind_Constant_Declaration
and then Get_Deferred_Declaration_Flag (El) = False
and then Get_Deferred_Declaration (El) /= Null_Iir
then
-- This is a full constant declaration which completes a previous
-- incomplete constant declaration.
--
-- Do not create the subtype of this full constant declaration,
-- since it was already created by the deferred declaration.
-- Use the type of the deferred declaration.
Deferred := Get_Deferred_Declaration (El);
Def := Get_Type (Deferred);
Info := Get_Info (Deferred);
Set_Info (El, Info);
else
Chap3.Translate_Object_Subtype_Indication (El);
Info := Add_Info (El, Kind_Object);
Def := Get_Type (El);
end if;
Tinfo := Get_Info (Def);
Obj_Type := Get_Object_Type (Tinfo, Mode_Value);
case Get_Kind (El) is
when Iir_Kind_Variable_Declaration
| Iir_Kind_Interface_Constant_Declaration =>
Info.Object_Var :=
Create_Var (Create_Var_Identifier (El), Obj_Type);
when Iir_Kind_Constant_Declaration =>
if Get_Deferred_Declaration (El) /= Null_Iir then
-- This is a full constant declaration (in a body) of a
-- deferred constant declaration (in a package).
Storage := O_Storage_Public;
else
Storage := Global_Storage;
end if;
if Info.Object_Var = Null_Var then
-- Not a full constant declaration (ie a value for an
-- already declared constant).
-- Must create the declaration.
if Chap7.Is_Static_Constant (El) then
Info.Object_Static := True;
Info.Object_Var := Create_Global_Const
(Create_Identifier (El), Obj_Type, Global_Storage,
O_Cnode_Null);
else
Info.Object_Static := False;
Info.Object_Var := Create_Var
(Create_Var_Identifier (El), Obj_Type, Global_Storage);
end if;
end if;
if Get_Deferred_Declaration (El) = Null_Iir
and then Info.Object_Static
and then Storage /= O_Storage_External
then
-- Deferred constant are never considered as locally static.
-- FIXME: to be improved ?
-- open_temp/close_temp only required for transient types.
Open_Temp;
Define_Global_Const
(Info.Object_Var,
Chap7.Translate_Static_Expression (Val, Def));
Close_Temp;
end if;
when others =>
Error_Kind ("create_objet", El);
end case;
end Create_Object;
procedure Create_Signal (Decl : Iir)
is
Sig_Type_Def : constant Iir := Get_Type (Decl);
Type_Info : Type_Info_Acc;
Info : Signal_Info_Acc;
begin
Chap3.Translate_Object_Subtype_Indication (Decl);
Type_Info := Get_Info (Sig_Type_Def);
Info := Add_Info (Decl, Kind_Signal);
Info.Signal_Sig := Create_Var
(Create_Var_Identifier (Decl, "_SIG", 0),
Get_Object_Type (Type_Info, Mode_Signal));
if Get_Kind (Decl) = Iir_Kind_Interface_Signal_Declaration then
-- For interfaces, create a pointer so that there is no need to
-- update a copy if the association is collapsed.
Info.Signal_Valp := Create_Var
(Create_Var_Identifier (Decl, "_VALP", 0),
Get_Object_Ptr_Type (Type_Info, Mode_Value));
if Get_Default_Value (Decl) /= Null_Iir then
-- Default value for ports.
Info.Signal_Val := Create_Var
(Create_Var_Identifier (Decl, "_INIT", 0),
Get_Object_Type (Type_Info, Mode_Value));
end if;
else
Info.Signal_Val := Create_Var
(Create_Var_Identifier (Decl, "_VAL", 0),
Get_Object_Type (Type_Info, Mode_Value));
end if;
case Get_Kind (Decl) is
when Iir_Kind_Signal_Declaration
| Iir_Kind_Interface_Signal_Declaration =>
Rtis.Generate_Signal_Rti (Decl);
when Iir_Kind_Guard_Signal_Declaration =>
-- No name created for guard signal.
null;
when others =>
Error_Kind ("create_signal", Decl);
end case;
end Create_Signal;
procedure Create_Implicit_Signal (Decl : Iir)
is
Sig_Type_Def : constant Iir := Get_Type (Decl);
Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type_Def);
Info : Signal_Info_Acc;
begin
-- The type of DECL is already known: either bit, or boolean or the
-- type of the prefix.
Info := Add_Info (Decl, Kind_Signal);
Info.Signal_Sig := Create_Var
(Create_Uniq_Identifier,
Get_Object_Type (Type_Info, Mode_Signal));
Info.Signal_Val := Create_Var
(Create_Uniq_Identifier,
Get_Object_Type (Type_Info, Mode_Value));
end Create_Implicit_Signal;
procedure Create_File_Object (El : Iir_File_Declaration)
is
Obj_Type_Def : constant Iir := Get_Type (El);
Obj_Type : constant O_Tnode :=
Get_Ortho_Type (Obj_Type_Def, Mode_Value);
Info : Ortho_Info_Acc;
begin
Info := Add_Info (El, Kind_Object);
Info.Object_Var := Create_Var (Create_Var_Identifier (El), Obj_Type);
end Create_File_Object;
procedure Create_Package_Interface (Inter : Iir)
is
Pkg : constant Iir := Get_Uninstantiated_Package_Decl (Inter);
Pkg_Info : constant Ortho_Info_Acc := Get_Info (Pkg);
Info : Ortho_Info_Acc;
begin
Info := Add_Info (Inter, Kind_Package_Instance);
-- The spec
Info.Package_Instance_Spec_Var :=
Create_Var (Create_Var_Identifier (Inter, "SPEC", 0),
Pkg_Info.Package_Spec_Ptr_Type);
Set_Scope_Via_Var_Ptr
(Info.Package_Instance_Spec_Scope,
Info.Package_Instance_Spec_Var);
-- The body
Info.Package_Instance_Body_Var :=
Create_Var (Create_Var_Identifier (Inter, "BODY", 0),
Pkg_Info.Package_Body_Ptr_Type);
Set_Scope_Via_Var_Ptr
(Info.Package_Instance_Body_Scope,
Info.Package_Instance_Body_Var);
Chap2.Instantiate_Info_Package (Inter);
end Create_Package_Interface;
procedure Allocate_Complex_Object (Obj_Type : Iir;
Alloc_Kind : Allocation_Kind;
Var : in out Mnode)
is
Type_Info : constant Type_Info_Acc := Get_Type_Info (Var);
Kind : constant Object_Kind_Type := Get_Object_Kind (Var);
begin
-- Cannot allocate unconstrained object (since size is unknown).
pragma Assert (Type_Info.Type_Mode not in Type_Mode_Unbounded);
if not Is_Complex_Type (Type_Info) then
-- Object is not complex.
return;
end if;
-- Allocate variable.
New_Assign_Stmt
(M2Lp (Var),
Gen_Alloc (Alloc_Kind,
Chap3.Get_Subtype_Size (Obj_Type, Mnode_Null, Kind),
Type_Info.Ortho_Ptr_Type (Kind)));
end Allocate_Complex_Object;
-- Note : OBJ can be a tree.
-- FIXME: should use translate_aggregate_others.
procedure Init_Array_Object (Obj : Mnode; Obj_Type : Iir)
is
-- Type of the object.
Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type);
Sobj : Mnode;
-- Iterator for the elements.
Index : O_Dnode;
Upper_Limit : O_Enode;
Upper_Var : O_Dnode;
Label : O_Snode;
begin
-- Iterate on all elements of the object.
Open_Temp;
if Type_Info.Type_Mode = Type_Mode_Unbounded_Array then
Sobj := Stabilize (Obj);
else
Sobj := Obj;
end if;
Upper_Limit := Chap3.Get_Array_Length (Sobj, Obj_Type);
if Type_Info.Type_Mode = Type_Mode_Static_Array then
Upper_Var := O_Dnode_Null;
else
-- Hoist the computation of the limit before the loop.
Upper_Var := Create_Temp_Init (Ghdl_Index_Type, Upper_Limit);
end if;
Index := Create_Temp (Ghdl_Index_Type);
Init_Var (Index);
Start_Loop_Stmt (Label);
if Upper_Var /= O_Dnode_Null then
Upper_Limit := New_Obj_Value (Upper_Var);
end if;
Gen_Exit_When (Label,
New_Compare_Op (ON_Eq,
New_Obj_Value (Index), Upper_Limit,
Ghdl_Bool_Type));
Init_Object
(Chap6.Translate_Indexed_Name_By_Offset (Sobj, Obj_Type, Index),
Get_Element_Subtype (Obj_Type));
Inc_Var (Index);
Finish_Loop_Stmt (Label);
Close_Temp;
end Init_Array_Object;
procedure Init_Protected_Object (Obj : Mnode; Obj_Type : Iir)
is
Info : constant Type_Info_Acc := Get_Info (Obj_Type);
Assoc : O_Assoc_List;
begin
-- Call the initializer.
Start_Association (Assoc, Info.B.Prot_Init_Subprg);
Subprgs.Add_Subprg_Instance_Assoc (Assoc, Info.B.Prot_Init_Instance);
-- Use of M2Lp is a little bit fragile (not sure we get the
-- variable, but should work: we didn't stabilize it).
New_Assign_Stmt (M2Lp (Obj), New_Function_Call (Assoc));
end Init_Protected_Object;
procedure Fini_Protected_Object (Decl : Iir)
is
Info : constant Type_Info_Acc := Get_Info (Get_Type (Decl));
Obj : Mnode;
Assoc : O_Assoc_List;
begin
Obj := Chap6.Translate_Name (Decl, Mode_Value);
-- Call the Finalizator.
Start_Association (Assoc, Info.B.Prot_Final_Subprg);
New_Association (Assoc, M2E (Obj));
New_Procedure_Call (Assoc);
end Fini_Protected_Object;
function Get_Scalar_Initial_Value (Atype : Iir) return O_Enode
is
Tinfo : constant Type_Info_Acc := Get_Info (Atype);
begin
case Tinfo.Type_Mode is
when Type_Mode_Scalar =>
return Chap14.Translate_Left_Type_Attribute (Atype);
when Type_Mode_Acc
| Type_Mode_Bounds_Acc =>
return New_Lit (New_Null_Access (Tinfo.Ortho_Type (Mode_Value)));
when others =>
Error_Kind ("get_scalar_initial_value", Atype);
end case;
end Get_Scalar_Initial_Value;
procedure Init_Object (Obj : Mnode; Obj_Type : Iir)
is
Tinfo : constant Type_Info_Acc := Get_Type_Info (Obj);
begin
case Tinfo.Type_Mode is
when Type_Mode_Scalar
| Type_Mode_Acc
| Type_Mode_Bounds_Acc =>
New_Assign_Stmt (M2Lv (Obj), Get_Scalar_Initial_Value (Obj_Type));
when Type_Mode_Arrays =>
Init_Array_Object (Obj, Obj_Type);
when Type_Mode_Records =>
declare
List : constant Iir_Flist :=
Get_Elements_Declaration_List (Obj_Type);
Sobj : Mnode;
El : Iir_Element_Declaration;
begin
Open_Temp;
Sobj := Stabilize (Obj);
for I in Flist_First .. Flist_Last (List) loop
El := Get_Nth_Element (List, I);
Init_Object (Chap6.Translate_Selected_Element (Sobj, El),
Get_Type (El));
end loop;
Close_Temp;
end;
when Type_Mode_Protected =>
Init_Protected_Object (Obj, Obj_Type);
when Type_Mode_Unknown
| Type_Mode_File =>
raise Internal_Error;
end case;
end Init_Object;
-- Return True iff subtype indication of DECL is a subtype attribute.
function Is_Object_Subtype_Attribute (Decl : Iir) return Boolean
is
Ind : constant Iir := Get_Subtype_Indication (Decl);
begin
return Ind /= Null_Iir
and then Get_Kind (Ind) = Iir_Kind_Subtype_Attribute;
end Is_Object_Subtype_Attribute;
procedure Elab_Subtype_Attribute
(Decl : Iir; Name_Val : Mnode; Name_Sig : Mnode)
is
Ind : constant Iir := Get_Subtype_Indication (Decl);
Name : Mnode;
Bnd : Mnode;
begin
Name := Chap6.Translate_Name (Get_Prefix (Ind), Mode_Value);
Bnd := Chap3.Get_Composite_Bounds (Name);
if Name_Sig /= Mnode_Null then
Stabilize (Bnd);
New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Name_Sig)),
M2Addr (Bnd));
end if;
New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Name_Val)),
M2Addr (Bnd));
end Elab_Subtype_Attribute;
procedure Elab_Maybe_Subtype_Attribute
(Decl : Iir; Name_Val : Mnode; Name_Sig : Mnode) is
begin
if not Is_Object_Subtype_Attribute (Decl) then
return;
end if;
Elab_Subtype_Attribute (Decl, Name_Val, Name_Sig);
end Elab_Maybe_Subtype_Attribute;
-- If SIZE is larger than the threshold, call __ghdl_check_stack_allocation
-- to raise an error if the size is too large. There are two threshold:
-- one set at compile time (Check_Stack_Allocation_Threshold) and one set
-- at run-time.
--
-- Right now, this function is called only for allocation of a complex
-- object on the stack (constant or variable). But there are more sources
-- of stack allocation (temporary aggregate, unbounded objects, individual
-- assocs...)
function Maybe_Check_Stack_Allocation (Size : O_Enode) return O_Enode
is
Val : O_Dnode;
If_Blk : O_If_Block;
Assoc : O_Assoc_List;
begin
if Flag_Check_Stack_Allocation = 0 then
return Size;
end if;
Val := Create_Temp_Init (Ghdl_Index_Type, Size);
Start_If_Stmt
(If_Blk,
New_Compare_Op (ON_Ge,
New_Obj_Value (Val),
New_Lit (Check_Stack_Allocation_Threshold),
Ghdl_Bool_Type));
Start_Association (Assoc, Ghdl_Check_Stack_Allocation);
New_Association (Assoc, New_Obj_Value (Val));
New_Procedure_Call (Assoc);
Finish_If_Stmt (If_Blk);
return New_Obj_Value (Val);
end Maybe_Check_Stack_Allocation;
procedure Elab_Object_Storage (Obj : Iir)
is
Obj_Type : constant Iir := Get_Type (Obj);
Obj_Info : constant Object_Info_Acc := Get_Info (Obj);
Name_Node : Mnode;
Type_Info : Type_Info_Acc;
Alloc_Kind : Allocation_Kind;
Size : O_Enode;
begin
-- Elaborate subtype.
case Get_Kind (Obj) is
when Iir_Kind_Attribute_Value =>
null;
when others =>
if Is_Object_Subtype_Attribute (Obj) then
Type_Info := Get_Info (Obj_Type);
if Type_Info.Type_Mode in Type_Mode_Unbounded then
-- Copy bounds and allocate base.
Name_Node :=
Get_Var (Obj_Info.Object_Var, Type_Info, Mode_Value);
Stabilize (Name_Node);
Elab_Maybe_Subtype_Attribute (Obj, Name_Node, Mnode_Null);
Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var);
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_Kind, Name_Node, Get_Base_Type (Obj_Type));
return;
end if;
else
Chap3.Elab_Object_Subtype_Indication (Obj);
end if;
end case;
-- Now the subtype is elaborated, its info is defined.
Type_Info := Get_Info (Obj_Type);
-- FIXME: the object type may be a fat array!
-- FIXME: fat array + aggregate ?
if Type_Info.Type_Mode = Type_Mode_Protected then
-- Protected object will be created by its INIT function.
null;
elsif Is_Unbounded_Type (Type_Info) then
-- Allocated during initialization.
null;
elsif Is_Complex_Type (Type_Info) then
-- FIXME: avoid allocation if the value is a string and
-- the object is a constant
Name_Node := Get_Var (Obj_Info.Object_Var, Type_Info, Mode_Value);
Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var);
Size := Chap3.Get_Subtype_Size (Obj_Type, Mnode_Null, Mode_Value);
if Alloc_Kind = Alloc_Stack then
Size := Maybe_Check_Stack_Allocation (Size);
end if;
-- Was: Allocate_Complex_Object.
New_Assign_Stmt
(M2Lp (Name_Node),
Gen_Alloc (Alloc_Kind,
Size,
Type_Info.Ortho_Ptr_Type (Mode_Value)));
end if;
end Elab_Object_Storage;
-- Generate code to create object OBJ and initialize it with value VAL.
procedure Elab_Object_Init
(Name : Mnode; Obj : Iir; Value : Iir; Alloc_Kind : Allocation_Kind)
is
Obj_Type : constant Iir := Get_Type (Obj);
Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type);
Name_Node : Mnode;
Value_Node : O_Enode;
begin
-- Note: no temporary variable region is created, as the allocation
-- may be performed on the stack.
if Value = Null_Iir then
-- Performs default initialization.
Open_Temp;
Init_Object (Name, Obj_Type);
Close_Temp;
elsif Get_Kind (Value) = Iir_Kind_Aggregate then
if Type_Info.Type_Mode in Type_Mode_Unbounded
and then not Is_Object_Subtype_Attribute (Obj)
then
-- Allocate.
declare
Aggr_Type : constant Iir := Get_Type (Value);
Aggr_Base_Type : constant Iir := Get_Base_Type (Aggr_Type);
begin
Name_Node := Stabilize (Name);
if Get_Constraint_State (Aggr_Type) /= Fully_Constrained then
-- Allocate bounds
Chap3.Allocate_Unbounded_Composite_Bounds
(Alloc_Kind, Name_Node, Aggr_Base_Type);
-- Translate bounds
Chap7.Translate_Aggregate_Bounds
(Stabilize (Chap3.Get_Composite_Bounds (Name_Node)),
Value);
-- Allocate base
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_Kind, Name_Node, Aggr_Base_Type);
else
Chap3.Create_Composite_Subtype (Aggr_Type);
if Alloc_Kind = Alloc_Stack then
-- Short-cut: don't allocate bounds.
New_Assign_Stmt
(M2Lp (Chap3.Get_Composite_Bounds (Name_Node)),
M2Addr (Chap3.Get_Composite_Type_Bounds (Aggr_Type)));
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_Kind, Name_Node, Aggr_Base_Type);
else
Chap3.Translate_Object_Allocation
(Name_Node, Alloc_Kind, Aggr_Base_Type,
Chap3.Get_Composite_Type_Bounds (Aggr_Type));
end if;
end if;
end;
else
Name_Node := Name;
end if;
Chap7.Translate_Aggregate (Name_Node, Obj_Type, Value);
else
Value_Node := Chap7.Translate_Expression (Value, Obj_Type);
if Type_Info.Type_Mode in Type_Mode_Unbounded then
declare
S : Mnode;
begin
Name_Node := Stabilize (Name);
S := Stabilize (E2M (Value_Node, Type_Info, Mode_Value));
if Get_Kind (Value) = Iir_Kind_String_Literal8
and then Get_Kind (Obj) = Iir_Kind_Constant_Declaration
then
-- No need to allocate space for the object.
Copy_Fat_Pointer (Name_Node, S);
else
Chap3.Translate_Object_Allocation
(Name_Node, Alloc_Kind, Obj_Type,
Chap3.Get_Composite_Bounds (S));
Chap3.Translate_Object_Copy (Name_Node, S, Obj_Type);
end if;
end;
else
Chap7.Translate_Assign (Name, Value_Node, Value, Obj_Type, Obj);
end if;
end if;
end Elab_Object_Init;
-- Generate code to create object OBJ and initialize it with value VAL.
procedure Elab_Object_Value (Obj : Iir; Value : Iir)
is
Obj_Info : constant Object_Info_Acc := Get_Info (Obj);
Alloc_Kind : constant Allocation_Kind :=
Get_Alloc_Kind_For_Var (Obj_Info.Object_Var);
Name : constant Mnode :=
Get_Var (Obj_Info.Object_Var, Get_Info (Get_Type (Obj)), Mode_Value);
begin
Elab_Object_Storage (Obj);
Elab_Object_Init (Name, Obj, Value, Alloc_Kind);
if Alloc_Kind = Alloc_Return then
-- If the object is allocated on the return stack, avoid
-- deallocation. Deallocation must be done manually (this concerns
-- procedures with suspension).
Disable_Stack2_Release;
end if;
end Elab_Object_Value;
-- Create code to elaborate OBJ.
procedure Elab_Object (Obj : Iir)
is
Value : constant Iir := Get_Default_Value (Obj);
Obj1 : Iir;
begin
-- Set default value.
if Get_Kind (Obj) = Iir_Kind_Constant_Declaration then
if Get_Deferred_Declaration_Flag (Obj) then
-- No code generation for a deferred constant.
return;
end if;
if Get_Kind (Value) = Iir_Kind_Overflow_Literal then
-- An overflow can be static, but must still generate an error
-- at run time.
Chap6.Gen_Bound_Error (Obj);
return;
end if;
if Get_Info (Obj).Object_Static then
-- A static object is pre-initialized.
return;
end if;
Obj1 := Get_Deferred_Declaration (Obj);
if Obj1 = Null_Iir then
Obj1 := Obj;
end if;
else
Obj1 := Obj;
end if;
New_Debug_Line_Stmt (Get_Line_Number (Obj));
-- Still use the default value of the not deferred constant.
-- FIXME: what about composite types.
Elab_Object_Value (Obj1, Value);
end Elab_Object;
procedure Fini_Object (Obj : Iir)
is
Obj_Type : constant Iir := Get_Type (Obj);
Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type);
begin
case Type_Mode_Valid (Type_Info.Type_Mode) is
when Type_Mode_Unbounded =>
declare
V : Mnode;
begin
Open_Temp;
V := Chap6.Translate_Name (Obj, Mode_Value);
Stabilize (V);
Chap3.Gen_Deallocate
(New_Value (M2Lp (Chap3.Get_Composite_Bounds (V))));
Chap3.Gen_Deallocate
(New_Value (M2Lp (Chap3.Get_Composite_Base (V))));
Close_Temp;
end;
when Type_Mode_Complex_Array
| Type_Mode_Complex_Record
| Type_Mode_Protected =>
Chap3.Gen_Deallocate
(New_Value (M2Lp (Chap6.Translate_Name (Obj, Mode_Value))));
when Type_Mode_Scalar
| Type_Mode_Static_Record
| Type_Mode_Static_Array
| Type_Mode_Acc
| Type_Mode_Bounds_Acc =>
null;
when Type_Mode_File =>
-- FIXME: free file ?
null;
end case;
end Fini_Object;
function Get_Nbr_Signals (Sig : Mnode; Sig_Type : Iir) return O_Enode
is
Info : constant Type_Info_Acc := Get_Info (Sig_Type);
begin
case Info.Type_Mode is
when Type_Mode_Scalar =>
-- Note: here we discard SIG...
return New_Lit (Ghdl_Index_1);
when Type_Mode_Arrays =>
declare
Len : O_Dnode;
If_Blk : O_If_Block;
Ssig : Mnode;
begin
Ssig := Stabilize (Sig);
Len := Create_Temp_Init
(Ghdl_Index_Type,
Chap3.Get_Array_Length (Ssig, Sig_Type));
-- Can dereference the first index only if the array is not a
-- null array.
Start_If_Stmt (If_Blk,
New_Compare_Op (ON_Neq,
New_Obj_Value (Len),
New_Lit (Ghdl_Index_0),
Ghdl_Bool_Type));
New_Assign_Stmt
(New_Obj (Len),
New_Dyadic_Op
(ON_Mul_Ov,
New_Obj_Value (Len),
Get_Nbr_Signals
(Chap3.Index_Base
(Chap3.Get_Composite_Base (Ssig), Sig_Type,
New_Lit (Ghdl_Index_0)),
Get_Element_Subtype (Sig_Type))));
Finish_If_Stmt (If_Blk);
return New_Obj_Value (Len);
end;
when Type_Mode_Records =>
declare
List : constant Iir_Flist :=
Get_Elements_Declaration_List (Get_Base_Type (Sig_Type));
El : Iir;
Res : O_Enode;
E : O_Enode;
Sig_El : Mnode;
Ssig : Mnode;
begin
Ssig := Stabilize (Sig);
Res := O_Enode_Null;
for I in Flist_First .. Flist_Last (List) loop
El := Get_Nth_Element (List, I);
Sig_El := Chap6.Translate_Selected_Element (Ssig, El);
E := Get_Nbr_Signals (Sig_El, Get_Type (El));
if Res /= O_Enode_Null then
Res := New_Dyadic_Op (ON_Add_Ov, Res, E);
else
Res := E;
end if;
end loop;
if Res = O_Enode_Null then
-- Empty records.
Res := New_Lit (Ghdl_Index_0);
end if;
return Res;
end;
when Type_Mode_Unknown
| Type_Mode_File
| Type_Mode_Acc
| Type_Mode_Bounds_Acc
| Type_Mode_Protected =>
raise Internal_Error;
end case;
end Get_Nbr_Signals;
-- Get the leftest signal of SIG.
-- The leftest signal of
-- a scalar signal is itself,
-- an array signal is the leftest,
-- a record signal is the first element.
function Get_Leftest_Signal (Sig: Mnode; Sig_Type : Iir)
return Mnode
is
Res : Mnode;
Res_Type : Iir;
Info : Type_Info_Acc;
begin
Res := Sig;
Res_Type := Sig_Type;
loop
Info := Get_Type_Info (Res);
case Info.Type_Mode is
when Type_Mode_Scalar =>
return Res;
when Type_Mode_Arrays =>
Res := Chap3.Index_Base
(Chap3.Get_Composite_Base (Res), Res_Type,
New_Lit (Ghdl_Index_0));
Res_Type := Get_Element_Subtype (Res_Type);
when Type_Mode_Records =>
declare
El_List : constant Iir_Flist :=
Get_Elements_Declaration_List (Get_Base_Type (Res_Type));
Element : constant Iir := Get_Nth_Element (El_List, 0);
begin
Res := Chap6.Translate_Selected_Element (Res, Element);
Res_Type := Get_Type (Element);
end;
when Type_Mode_Unknown
| Type_Mode_File
| Type_Mode_Acc
| Type_Mode_Bounds_Acc
| Type_Mode_Protected =>
raise Internal_Error;
end case;
end loop;
end Get_Leftest_Signal;
-- Add func and instance.
procedure Add_Associations_For_Resolver
(Assoc : in out O_Assoc_List; Func_Decl : Iir)
is
Func_Info : constant Subprg_Info_Acc := Get_Info (Func_Decl);
Resolv_Info : constant Subprg_Resolv_Info_Acc :=
Func_Info.Subprg_Resolv;
Val : O_Enode;
begin
New_Association
(Assoc, New_Lit (New_Subprogram_Address (Resolv_Info.Resolv_Func,
Ghdl_Ptr_Type)));
if Subprgs.Has_Subprg_Instance (Resolv_Info.Var_Instance) then
Val := New_Convert_Ov
(Subprgs.Get_Subprg_Instance (Resolv_Info.Var_Instance),
Ghdl_Ptr_Type);
else
Val := New_Lit (New_Null_Access (Ghdl_Ptr_Type));
end if;
New_Association (Assoc, Val);
end Add_Associations_For_Resolver;
type O_If_Block_Acc is access O_If_Block;
type Elab_Signal_Data is record
Value : Mnode;
-- Default value of the signal.
Init_Val : Mnode;
-- If statement for a block of signals.
If_Stmt : O_If_Block_Acc;
-- True if the default value is set.
Has_Val : Boolean;
-- True if a resolution function was already attached.
Already_Resolved : Boolean;
-- True if the signal may already have been created.
Check_Null : Boolean;
end record;
procedure Elab_Signal_Non_Composite (Targ : Mnode;
Targ_Type : Iir;
Data : Elab_Signal_Data)
is
Type_Info : constant Type_Info_Acc := Get_Info (Targ_Type);
Create_Subprg : O_Dnode;
Res : O_Enode;
Assoc : O_Assoc_List;
Init_Val : O_Enode;
-- For the resolution function (if any).
Func : Iir;
If_Stmt : O_If_Block;
Targ_Ptr : O_Dnode;
Value : Mnode;
begin
if Data.Check_Null then
Targ_Ptr := Create_Temp_Init
(Ghdl_Signal_Ptr_Ptr,
New_Unchecked_Address (M2Lv (Targ), Ghdl_Signal_Ptr_Ptr));
Start_If_Stmt
(If_Stmt,
New_Compare_Op (ON_Eq,
New_Value (New_Acc_Value (New_Obj (Targ_Ptr))),
New_Lit (New_Null_Access (Ghdl_Signal_Ptr)),
Ghdl_Bool_Type));
end if;
-- Set the value.
Value := Stabilize (Data.Value);
if Data.Has_Val then
Init_Val := M2E (Data.Init_Val);
else
Init_Val := Get_Scalar_Initial_Value (Targ_Type);
end if;
New_Assign_Stmt (M2Lv (Value), Init_Val);
-- Create the signal.
case Type_Mode_Scalar (Type_Info.Type_Mode) is
when Type_Mode_Scalar (Type_Mode_B1) =>
Create_Subprg := Ghdl_Create_Signal_B1;
when Type_Mode_E8 =>
Create_Subprg := Ghdl_Create_Signal_E8;
when Type_Mode_E32 =>
Create_Subprg := Ghdl_Create_Signal_E32;
when Type_Mode_I32
| Type_Mode_P32 =>
Create_Subprg := Ghdl_Create_Signal_I32;
when Type_Mode_P64
| Type_Mode_I64 =>
Create_Subprg := Ghdl_Create_Signal_I64;
when Type_Mode_F64 =>
Create_Subprg := Ghdl_Create_Signal_F64;
end case;
Start_Association (Assoc, Create_Subprg);
New_Association
(Assoc, New_Unchecked_Address (M2Lv (Value), Ghdl_Ptr_Type));
if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then
Func := Has_Resolution_Function (Targ_Type);
else
Func := Null_Iir;
end if;
if Func /= Null_Iir and then not Data.Already_Resolved then
Add_Associations_For_Resolver (Assoc, Func);
else
New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type)));
New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type)));
end if;
Res := New_Function_Call (Assoc);
if Data.Check_Null then
New_Assign_Stmt (New_Acc_Value (New_Obj (Targ_Ptr)), Res);
Finish_If_Stmt (If_Stmt);
else
New_Assign_Stmt
(M2Lv (Targ),
New_Convert_Ov (Res, Type_Info.Ortho_Type (Mode_Signal)));
end if;
end Elab_Signal_Non_Composite;
function Elab_Signal_Prepare_Composite
(Targ : Mnode; Targ_Type : Iir; Data : Elab_Signal_Data)
return Elab_Signal_Data
is
Assoc : O_Assoc_List;
Func : Iir;
Res : Elab_Signal_Data;
begin
Res := Data;
if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then
Func := Has_Resolution_Function (Targ_Type);
if Func /= Null_Iir and then not Data.Already_Resolved then
if Data.Check_Null then
Res.If_Stmt := new O_If_Block;
Start_If_Stmt
(Res.If_Stmt.all,
New_Compare_Op
(ON_Eq,
New_Convert_Ov (M2E (Get_Leftest_Signal (Targ,
Targ_Type)),
Ghdl_Signal_Ptr),
New_Lit (New_Null_Access (Ghdl_Signal_Ptr)),
Ghdl_Bool_Type));
--Res.Check_Null := False;
end if;
-- Add resolver.
Start_Association (Assoc, Ghdl_Signal_Create_Resolution);
Add_Associations_For_Resolver (Assoc, Func);
New_Association
(Assoc, New_Convert_Ov (M2Addr (Targ), Ghdl_Ptr_Type));
New_Association (Assoc, Get_Nbr_Signals (Targ, Targ_Type));
New_Procedure_Call (Assoc);
Res.Already_Resolved := True;
end if;
end if;
case Get_Info (Targ_Type).Type_Mode is
when Type_Mode_Records =>
Res.Value := Stabilize (Data.Value);
if Data.Has_Val then
Res.Init_Val := Stabilize (Data.Init_Val);
end if;
when Type_Mode_Arrays =>
Res.Value := Chap3.Get_Composite_Base (Data.Value);
if Data.Has_Val then
Res.Init_Val := Chap3.Get_Composite_Base (Data.Init_Val);
end if;
when others =>
raise Internal_Error;
end case;
return Res;
end Elab_Signal_Prepare_Composite;
procedure Elab_Signal_Finish_Composite (Data : in out Elab_Signal_Data)
is
procedure Free is new Ada.Unchecked_Deallocation
(Object => O_If_Block, Name => O_If_Block_Acc);
begin
if Data.If_Stmt /= null then
Finish_If_Stmt (Data.If_Stmt.all);
Free (Data.If_Stmt);
end if;
end Elab_Signal_Finish_Composite;
function Elab_Signal_Update_Array
(Data : Elab_Signal_Data; Targ_Type : Iir; Index : O_Dnode)
return Elab_Signal_Data
is
N_Init_Val : Mnode;
begin
if Data.Has_Val then
N_Init_Val := Chap3.Index_Base (Data.Init_Val, Targ_Type,
New_Obj_Value (Index));
else
N_Init_Val := Mnode_Null;
end if;
return Elab_Signal_Data'
(Value => Chap3.Index_Base (Data.Value, Targ_Type,
New_Obj_Value (Index)),
Init_Val => N_Init_Val,
Has_Val => Data.Has_Val,
If_Stmt => null,
Already_Resolved => Data.Already_Resolved,
Check_Null => Data.Check_Null);
end Elab_Signal_Update_Array;
function Elab_Signal_Update_Record
(Data : Elab_Signal_Data; Targ_Type : Iir; El : Iir_Element_Declaration)
return Elab_Signal_Data
is
pragma Unreferenced (Targ_Type);
N_Init_Val : Mnode;
begin
if Data.Has_Val then
N_Init_Val := Chap6.Translate_Selected_Element (Data.Init_Val, El);
else
N_Init_Val := Mnode_Null;
end if;
return Elab_Signal_Data'
(Value => Chap6.Translate_Selected_Element (Data.Value, El),
Init_Val => N_Init_Val,
Has_Val => Data.Has_Val,
If_Stmt => null,
Already_Resolved => Data.Already_Resolved,
Check_Null => Data.Check_Null);
end Elab_Signal_Update_Record;
procedure Elab_Signal is new Foreach_Non_Composite
(Data_Type => Elab_Signal_Data,
Composite_Data_Type => Elab_Signal_Data,
Do_Non_Composite => Elab_Signal_Non_Composite,
Prepare_Data_Array => Elab_Signal_Prepare_Composite,
Update_Data_Array => Elab_Signal_Update_Array,
Finish_Data_Array => Elab_Signal_Finish_Composite,
Prepare_Data_Record => Elab_Signal_Prepare_Composite,
Update_Data_Record => Elab_Signal_Update_Record,
Finish_Data_Record => Elab_Signal_Finish_Composite);
-- Elaborate signal subtypes and allocate the storage for the object.
procedure Elab_Signal_Declaration_Storage (Decl : Iir; Has_Copy : Boolean)
is
Is_Port : constant Boolean :=
Get_Kind (Decl) = Iir_Kind_Interface_Signal_Declaration;
Sig_Type : constant Iir := Get_Type (Decl);
Type_Info : Type_Info_Acc;
Name_Sig : Mnode;
Name_Val : Mnode;
begin
New_Debug_Line_Stmt (Get_Line_Number (Decl));
Open_Temp;
Chap3.Elab_Object_Subtype_Indication (Decl);
Type_Info := Get_Info (Sig_Type);
if Type_Info.Type_Mode in Type_Mode_Unbounded then
-- Allocate storage.
if Has_Copy then
Name_Sig := Chap6.Translate_Name (Decl, Mode_Signal);
Name_Val := Mnode_Null;
else
Chap6.Translate_Signal_Name (Decl, Name_Sig, Name_Val);
end if;
Name_Sig := Stabilize (Name_Sig);
if Name_Val /= Mnode_Null then
Name_Val := Stabilize (Name_Val);
Elab_Maybe_Subtype_Attribute (Decl, Name_Val, Name_Sig);
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_System, Name_Val, Sig_Type);
else
Elab_Maybe_Subtype_Attribute (Decl, Name_Sig, Mnode_Null);
end if;
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_System, Name_Sig, Sig_Type);
if Is_Port and then Get_Default_Value (Decl) /= Null_Iir then
Name_Val := Chap6.Get_Port_Init_Value (Decl);
Name_Val := Stabilize (Name_Val);
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_System, Name_Val, Sig_Type);
end if;
elsif Is_Complex_Type (Type_Info) then
if Has_Copy then
Name_Sig := Chap6.Translate_Name (Decl, Mode_Signal);
Name_Val := Mnode_Null;
else
Chap6.Translate_Signal_Name (Decl, Name_Sig, Name_Val);
end if;
Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Sig);
if Name_Val /= Mnode_Null then
Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Val);
end if;
if Is_Port and then Get_Default_Value (Decl) /= Null_Iir then
Name_Val := Chap6.Get_Port_Init_Value (Decl);
Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Val);
end if;
elsif Is_Port then
if not Has_Copy then
-- A port that isn't collapsed. Allocate value.
Name_Val := Chap6.Translate_Name (Decl, Mode_Value);
New_Assign_Stmt
(M2Lp (Name_Val),
Gen_Alloc (Alloc_System,
Chap3.Get_Object_Size (Name_Val, Sig_Type),
Type_Info.Ortho_Ptr_Type (Mode_Value)));
end if;
end if;
Close_Temp;
end Elab_Signal_Declaration_Storage;
function Has_Direct_Driver (Sig : Iir) return Boolean
is
Info : constant Ortho_Info_Acc := Get_Info (Get_Object_Prefix (Sig));
begin
-- Can be an alias ?
return Info.Kind = Kind_Signal
and then Info.Signal_Driver /= Null_Var;
end Has_Direct_Driver;
procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir)
is
Sig_Type : constant Iir := Get_Type (Decl);
Sig_Info : constant Ortho_Info_Acc := Get_Info (Decl);
Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type);
Name_Node : Mnode;
begin
Open_Temp;
if Type_Info.Type_Mode in Type_Mode_Unbounded then
Name_Node := Get_Var (Sig_Info.Signal_Driver, Type_Info, Mode_Value);
Name_Node := Stabilize (Name_Node);
-- Copy bounds from signal.
New_Assign_Stmt
(M2Lp (Chap3.Get_Composite_Bounds (Name_Node)),
M2Addr (Chap3.Get_Composite_Bounds
(Chap6.Translate_Name (Decl, Mode_Signal))));
-- Allocate base.
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_System, Name_Node, Sig_Type);
elsif Is_Complex_Type (Type_Info) then
Name_Node := Get_Var (Sig_Info.Signal_Driver, Type_Info, Mode_Value);
Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node);
end if;
Close_Temp;
end Elab_Direct_Driver_Declaration_Storage;
-- Create signal object.
-- Note: SIG can be a signal sub-element (used when signals are
-- collapsed).
-- If CHECK_NULL is TRUE, create the signal only if it was not yet
-- created.
procedure Elab_Signal_Declaration_Object
(Sig : Iir; Parent : Iir; Check_Null : Boolean)
is
Decl : constant Iir := Strip_Denoting_Name (Sig);
Sig_Type : constant Iir := Get_Type (Sig);
Base_Decl : constant Iir := Get_Object_Prefix (Sig);
Val_Type : Iir;
Name_Sig : Mnode;
Name_Val : Mnode;
Value : Iir;
Data : Elab_Signal_Data;
begin
New_Debug_Line_Stmt (Get_Line_Number (Sig));
Open_Temp;
-- Set the name of the signal.
declare
Assoc : O_Assoc_List;
begin
Start_Association (Assoc, Ghdl_Signal_Name_Rti);
New_Association
(Assoc,
New_Unchecked_Address (New_Obj (Get_Info (Base_Decl).Signal_Rti),
Rtis.Ghdl_Rti_Access));
Rtis.Associate_Rti_Context (Assoc, Parent);
New_Procedure_Call (Assoc);
end;
Chap6.Translate_Signal_Name (Decl, Name_Sig, Name_Val);
-- Consistency check: a signal name is a signal.
pragma Assert (Get_Object_Kind (Name_Sig) = Mode_Signal);
Data.Value := Name_Val;
if Decl = Base_Decl then
Data.Already_Resolved := False;
Data.Check_Null := Check_Null;
Value := Get_Default_Value (Base_Decl);
if Value = Null_Iir then
Data.Has_Val := False;
else
Data.Has_Val := True;
Val_Type := Get_Type (Value);
if Get_Kind (Value) = Iir_Kind_Aggregate
and then Get_Constraint_State (Sig_Type) /= Fully_Constrained
and then Get_Constraint_State (Val_Type) /= Fully_Constrained
then
-- Both the signal type and the value type are not fully
-- constrained. This can happend when the signal subtype
-- indication is 'subtype and the default value is an
-- aggregate. The signal was created with bounds, so use
-- those bounds.
declare
Tinfo : constant Type_Info_Acc := Get_Info (Sig_Type);
V : Mnode;
begin
Stabilize (Data.Value);
V := Create_Temp (Tinfo);
New_Assign_Stmt
(M2Lp (Chap3.Get_Composite_Bounds (V)),
M2Addr (Chap3.Get_Composite_Bounds (Data.Value)));
pragma Assert (Val_Type = Sig_Type);
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_Stack, V, Sig_Type);
Chap7.Translate_Aggregate (V, Val_Type, Value);
Data.Init_Val := V;
end;
else
Data.Init_Val := Chap7.Translate_Expression (Value, Sig_Type);
end if;
end if;
else
-- Sub signal.
-- Do not add resolver.
-- Do not use default value.
Data.Already_Resolved := True;
Data.Has_Val := False;
Data.Check_Null := False;
Value := Null_Iir;
end if;
Elab_Signal (Name_Sig, Sig_Type, Data);
Close_Temp;
if Value /= Null_Iir then
Chap9.Destroy_Types (Value);
end if;
end Elab_Signal_Declaration_Object;
procedure Elab_Signal_Declaration
(Decl : Iir; Parent : Iir; Check_Null : Boolean)
is
begin
Elab_Signal_Declaration_Storage (Decl, False);
Elab_Signal_Declaration_Object (Decl, Parent, Check_Null);
end Elab_Signal_Declaration;
procedure Elab_Signal_Attribute (Decl : Iir)
is
Info : constant Signal_Info_Acc := Get_Info (Decl);
Dtype : constant Iir := Get_Type (Decl);
Type_Info : constant Type_Info_Acc := Get_Info (Dtype);
Assoc : O_Assoc_List;
Prefix : Iir;
Prefix_Node : Mnode;
Res : O_Enode;
Val : O_Enode;
Param : Iir;
Subprg : O_Dnode;
begin
New_Debug_Line_Stmt (Get_Line_Number (Decl));
-- Create the signal (with the time)
case Get_Kind (Decl) is
when Iir_Kind_Stable_Attribute =>
Subprg := Ghdl_Create_Stable_Signal;
when Iir_Kind_Quiet_Attribute =>
Subprg := Ghdl_Create_Quiet_Signal;
when Iir_Kind_Transaction_Attribute =>
Subprg := Ghdl_Create_Transaction_Signal;
when others =>
Error_Kind ("elab_signal_attribute", Decl);
end case;
Start_Association (Assoc, Subprg);
New_Association (Assoc,
New_Unchecked_Address (Get_Var (Info.Signal_Val),
Ghdl_Ptr_Type));
case Get_Kind (Decl) is
when Iir_Kind_Stable_Attribute
| Iir_Kind_Quiet_Attribute =>
Param := Get_Parameter (Decl);
if Param = Null_Iir then
Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0));
else
Val := Chap7.Translate_Expression (Param);
end if;
New_Association (Assoc, Val);
when others =>
null;
end case;
Res := New_Convert_Ov (New_Function_Call (Assoc),
Type_Info.Ortho_Type (Mode_Signal));
New_Assign_Stmt (Get_Var (Info.Signal_Sig), Res);
-- Register all signals this depends on.
Prefix := Get_Prefix (Decl);
Prefix_Node := Chap6.Translate_Name (Prefix, Mode_Signal);
Register_Signal (Prefix_Node, Get_Type (Prefix),
Ghdl_Signal_Attribute_Register_Prefix);
end Elab_Signal_Attribute;
type Delayed_Signal_Data is record
-- Value part of the signal. The signal itself is passed by a
-- parameter.
Targ_Val : Mnode;
-- Prefix signal.
Pfx : Mnode;
-- Delay time.
Param : Iir;
end record;
procedure Create_Delayed_Signal_Noncomposite
(Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data)
is
pragma Unreferenced (Targ_Type);
Assoc : O_Assoc_List;
Type_Info : Type_Info_Acc;
Val : O_Enode;
begin
Start_Association (Assoc, Ghdl_Create_Delayed_Signal);
New_Association
(Assoc,
New_Convert_Ov (New_Value (M2Lv (Data.Pfx)), Ghdl_Signal_Ptr));
New_Association
(Assoc,
New_Unchecked_Address (M2Lv (Data.Targ_Val), Ghdl_Ptr_Type));
if Data.Param = Null_Iir then
Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0));
else
Val := Chap7.Translate_Expression (Data.Param);
end if;
New_Association (Assoc, Val);
Type_Info := Get_Type_Info (Targ);
New_Assign_Stmt
(M2Lv (Targ),
New_Convert_Ov (New_Function_Call (Assoc),
Type_Info.Ortho_Type (Mode_Signal)));
end Create_Delayed_Signal_Noncomposite;
function Create_Delayed_Signal_Prepare_Composite
(Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data)
return Delayed_Signal_Data
is
pragma Unreferenced (Targ_Type);
Res : Delayed_Signal_Data;
begin
Res.Param := Data.Param;
if Get_Type_Info (Targ).Type_Mode in Type_Mode_Bounded_Records then
Res.Targ_Val := Stabilize (Data.Targ_Val);
Res.Pfx := Stabilize (Data.Pfx);
else
Res.Targ_Val := Chap3.Get_Composite_Base (Data.Targ_Val);
Res.Pfx := Chap3.Get_Composite_Base (Data.Pfx);
end if;
return Res;
end Create_Delayed_Signal_Prepare_Composite;
function Create_Delayed_Signal_Update_Data_Array
(Data : Delayed_Signal_Data; Targ_Type : Iir; Index : O_Dnode)
return Delayed_Signal_Data
is
begin
return Delayed_Signal_Data'
(Targ_Val => Chap3.Index_Base (Data.Targ_Val, Targ_Type,
New_Obj_Value (Index)),
Pfx => Chap3.Index_Base (Data.Pfx, Targ_Type,
New_Obj_Value (Index)),
Param => Data.Param);
end Create_Delayed_Signal_Update_Data_Array;
function Create_Delayed_Signal_Update_Data_Record
(Data : Delayed_Signal_Data;
Targ_Type : Iir;
El : Iir_Element_Declaration)
return Delayed_Signal_Data
is
pragma Unreferenced (Targ_Type);
begin
return Delayed_Signal_Data'
(Targ_Val => Chap6.Translate_Selected_Element (Data.Targ_Val, El),
Pfx => Chap6.Translate_Selected_Element (Data.Pfx, El),
Param => Data.Param);
end Create_Delayed_Signal_Update_Data_Record;
procedure Create_Delayed_Signal is new Foreach_Non_Composite
(Data_Type => Delayed_Signal_Data,
Composite_Data_Type => Delayed_Signal_Data,
Do_Non_Composite => Create_Delayed_Signal_Noncomposite,
Prepare_Data_Array => Create_Delayed_Signal_Prepare_Composite,
Update_Data_Array => Create_Delayed_Signal_Update_Data_Array,
Prepare_Data_Record => Create_Delayed_Signal_Prepare_Composite,
Update_Data_Record => Create_Delayed_Signal_Update_Data_Record);
procedure Elab_Signal_Delayed_Attribute (Decl : Iir)
is
Sig_Type : constant Iir := Get_Type (Decl);
Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type);
Name_Sig, Name_Val : Mnode;
Pfx_Node : Mnode;
Data : Delayed_Signal_Data;
begin
Chap6.Translate_Signal_Name (Decl, Name_Sig, Name_Val);
if Is_Complex_Type (Type_Info) then
Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Sig);
Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Val);
-- We cannot stabilize NAME_NODE, since Allocate_Complex_Object
-- assign it.
Chap6.Translate_Signal_Name (Decl, Name_Sig, Name_Val);
end if;
Pfx_Node := Chap6.Translate_Name (Get_Prefix (Decl), Mode_Signal);
Data := Delayed_Signal_Data'(Targ_Val => Name_Val,
Pfx => Pfx_Node,
Param => Get_Parameter (Decl));
Create_Delayed_Signal (Name_Sig, Sig_Type, Data);
end Elab_Signal_Delayed_Attribute;
procedure Elab_File_Declaration (Decl : Iir_File_Declaration)
is
Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (Decl));
File_Name : constant Iir := Get_File_Logical_Name (Decl);
Constr : O_Assoc_List;
Name : Mnode;
Open_Kind : Iir;
Mode_Val : O_Enode;
Str : O_Enode;
Info : Type_Info_Acc;
begin
-- Elaborate the file.
Name := Chap6.Translate_Name (Decl, Mode_Value);
if Is_Text then
Start_Association (Constr, Ghdl_Text_File_Elaborate);
else
Start_Association (Constr, Ghdl_File_Elaborate);
Info := Get_Info (Get_Type (Decl));
if Info.B.File_Signature /= O_Dnode_Null then
New_Association
(Constr, New_Address (New_Obj (Info.B.File_Signature),
Char_Ptr_Type));
else
New_Association (Constr,
New_Lit (New_Null_Access (Char_Ptr_Type)));
end if;
end if;
New_Assign_Stmt (M2Lv (Name), New_Function_Call (Constr));
-- If file_open_information is present, open the file.
if File_Name = Null_Iir then
return;
end if;
Open_Temp;
Name := Chap6.Translate_Name (Decl, Mode_Value);
Open_Kind := Get_File_Open_Kind (Decl);
if Open_Kind /= Null_Iir then
-- VHDL 93 and later.
Mode_Val := New_Convert_Ov
(Chap7.Translate_Expression (Open_Kind), Ghdl_I32_Type);
else
-- VHDL 87.
case Get_Mode (Decl) is
when Iir_In_Mode =>
Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0));
when Iir_Out_Mode =>
Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1));
when others =>
raise Internal_Error;
end case;
end if;
Str := Chap7.Translate_Expression (File_Name, String_Type_Definition);
if Is_Text then
Start_Association (Constr, Ghdl_Text_File_Open);
else
Start_Association (Constr, Ghdl_File_Open);
end if;
New_Association (Constr, M2E (Name));
New_Association (Constr, Mode_Val);
New_Association (Constr, Str);
New_Procedure_Call (Constr);
Close_Temp;
end Elab_File_Declaration;
procedure Final_File_Declaration (Decl : Iir_File_Declaration)
is
Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (Decl));
Constr : O_Assoc_List;
Name : Mnode;
begin
Open_Temp;
Name := Chap6.Translate_Name (Decl, Mode_Value);
Stabilize (Name);
-- LRM 3.4.1 File Operations
-- An implicit call to FILE_CLOSE exists in a subprogram body for
-- every file object declared in the corresponding subprogram
-- declarative part. Each such call associates a unique file object
-- with the formal parameter F and is called whenever the
-- corresponding subprogram completes its execution.
if Is_Text then
Start_Association (Constr, Ghdl_Text_File_Close);
else
Start_Association (Constr, Ghdl_File_Close);
end if;
New_Association (Constr, M2E (Name));
New_Procedure_Call (Constr);
if Is_Text then
Start_Association (Constr, Ghdl_Text_File_Finalize);
else
Start_Association (Constr, Ghdl_File_Finalize);
end if;
New_Association (Constr, M2E (Name));
New_Procedure_Call (Constr);
Close_Temp;
end Final_File_Declaration;
procedure Translate_Type_Declaration (Decl : Iir)
is
Def : constant Iir := Get_Type_Definition (Decl);
Mark : Id_Mark_Type;
begin
Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
case Get_Kind (Def) is
when Iir_Kinds_Subtype_Definition =>
Chap3.Translate_Subtype_Indication (Def, True);
raise Internal_Error;
when others =>
Chap3.Translate_Type_Definition (Def);
end case;
Pop_Identifier_Prefix (Mark);
end Translate_Type_Declaration;
procedure Translate_Anonymous_Type_Declaration (Decl : Iir)
is
Mark : Id_Mark_Type;
Mark1 : Id_Mark_Type;
begin
Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
Push_Identifier_Prefix (Mark1, "BT");
Chap3.Translate_Type_Definition (Get_Type_Definition (Decl));
Pop_Identifier_Prefix (Mark1);
Pop_Identifier_Prefix (Mark);
end Translate_Anonymous_Type_Declaration;
procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration)
is
Def : constant Iir := Get_Type (Decl);
Mark : Id_Mark_Type;
begin
Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
Chap3.Translate_Subtype_Definition (Def, True);
Pop_Identifier_Prefix (Mark);
end Translate_Subtype_Declaration;
procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration)
is
Mark : Id_Mark_Type;
begin
Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
Chap3.Translate_Bool_Type_Definition (Get_Type_Definition (Decl));
Pop_Identifier_Prefix (Mark);
end Translate_Bool_Type_Declaration;
procedure Translate_Object_Alias_Declaration
(Decl : Iir_Object_Alias_Declaration)
is
Decl_Type : constant Iir := Get_Type (Decl);
Name : constant Iir := Get_Name (Decl);
Info : Alias_Info_Acc;
Tinfo : Type_Info_Acc;
Atype : O_Tnode;
Id : Var_Ident_Type;
begin
Chap3.Translate_Object_Subtype_Indication (Decl, True);
Info := Add_Info (Decl, Kind_Alias);
if Is_Signal_Name (Decl) then
Info.Alias_Kind := Mode_Signal;
else
Info.Alias_Kind := Mode_Value;
end if;
Tinfo := Get_Info (Decl_Type);
for Mode in Mode_Value .. Info.Alias_Kind loop
case Tinfo.Type_Mode is
when Type_Mode_Unbounded =>
-- create an object.
-- At elaboration: copy base from name, copy bounds from type,
-- check for matching bounds.
Atype := Get_Ortho_Type (Decl_Type, Mode);
when Type_Mode_Bounded_Arrays
| Type_Mode_Bounded_Records
| Type_Mode_Acc
| Type_Mode_Bounds_Acc
| Type_Mode_Protected =>
-- Create an object pointer.
-- At elaboration: copy base from name.
Atype := Tinfo.Ortho_Ptr_Type (Mode);
when Type_Mode_Scalar =>
case Mode is
when Mode_Signal =>
Atype := Tinfo.Ortho_Type (Mode_Signal);
when Mode_Value =>
Atype := Tinfo.Ortho_Ptr_Type (Mode_Value);
end case;
when others =>
raise Internal_Error;
end case;
if Mode = Mode_Signal then
Id := Create_Var_Identifier (Decl, "_SIG", 0);
else
Id := Create_Var_Identifier (Decl);
end if;
Info.Alias_Var (Mode) := Create_Var (Id, Atype);
end loop;
if Get_Kind (Name) = Iir_Kind_Slice_Name
and then Info.Alias_Kind = Mode_Signal
then
-- The name subtype will be evaluated once at elaboration, as it is
-- needed when direct drivers are used (in that case, the name is
-- evaluated once again).
declare
Name_Type : constant Iir := Get_Type (Name);
Mark1, Mark2 : Id_Mark_Type;
begin
Push_Identifier_Prefix (Mark1, Get_Identifier (Decl));
Push_Identifier_Prefix (Mark2, "AT");
Chap3.Translate_Array_Subtype (Name_Type);
Pop_Identifier_Prefix (Mark2);
Pop_Identifier_Prefix (Mark1);
end;
end if;
end Translate_Object_Alias_Declaration;
procedure Elab_Object_Alias_Declaration
(Decl : Iir_Object_Alias_Declaration)
is
Decl_Type : constant Iir := Get_Type (Decl);
Tinfo : constant Type_Info_Acc := Get_Info (Decl_Type);
Name : constant Iir := Get_Name (Decl);
Name_Type : constant Iir := Get_Type (Name);
Alias_Info : constant Alias_Info_Acc := Get_Info (Decl);
Name_Node : Mnode_Array;
begin
New_Debug_Line_Stmt (Get_Line_Number (Decl));
Chap3.Elab_Object_Subtype_Indication (Decl);
Open_Temp;
if Get_Kind (Name) = Iir_Kind_Slice_Name
and then Alias_Info.Alias_Kind = Mode_Signal
then
-- See Translate_Object_Alias_Declaration.
Chap3.Elab_Array_Subtype (Name_Type);
end if;
case Alias_Info.Alias_Kind is
when Mode_Value =>
Name_Node (Mode_Value) := Chap6.Translate_Name (Name, Mode_Value);
when Mode_Signal =>
Chap6.Translate_Signal_Name
(Name, Name_Node (Mode_Signal), Name_Node (Mode_Value));
end case;
for Mode in Mode_Value .. Alias_Info.Alias_Kind loop
declare
N : Mnode renames Name_Node (Mode);
A : Var_Type renames Alias_Info.Alias_Var (Mode);
Alias_Node : Mnode;
begin
-- FIXME: use subtype conversion ?
case Tinfo.Type_Mode is
when Type_Mode_Unbounded =>
Stabilize (N);
Alias_Node := Stabilize (Get_Var (A, Tinfo, Mode));
Chap7.Convert_Constrained_To_Unconstrained (Alias_Node, N);
when Type_Mode_Bounded_Arrays =>
Stabilize (N);
New_Assign_Stmt
(Get_Var (A),
New_Convert_Ov (M2E (Chap3.Get_Composite_Base (N)),
Tinfo.Ortho_Ptr_Type (Mode)));
Chap3.Check_Composite_Match
(Decl_Type, T2M (Decl_Type, Mode),
Name_Type, N, Decl);
when Type_Mode_Acc
| Type_Mode_Bounds_Acc
| Type_Mode_Protected =>
New_Assign_Stmt (Get_Var (A), M2Addr (N));
when Type_Mode_Scalar =>
case Mode is
when Mode_Value =>
New_Assign_Stmt (Get_Var (A), M2Addr (N));
when Mode_Signal =>
New_Assign_Stmt (Get_Var (A), M2E (N));
end case;
when Type_Mode_Bounded_Records =>
Stabilize (N);
-- FIXME: Check ?
New_Assign_Stmt (Get_Var (A), M2Addr (N));
when others =>
raise Internal_Error;
end case;
end;
end loop;
Close_Temp;
end Elab_Object_Alias_Declaration;
procedure Translate_Port_Chain (Parent : Iir)
is
Port : Iir;
begin
Port := Get_Port_Chain (Parent);
while Port /= Null_Iir loop
Create_Signal (Port);
Port := Get_Chain (Port);
end loop;
end Translate_Port_Chain;
procedure Translate_Generic_Chain (Parent : Iir)
is
Decl : Iir;
begin
Decl := Get_Generic_Chain (Parent);
while Decl /= Null_Iir loop
case Get_Kind (Decl) is
when Iir_Kinds_Interface_Object_Declaration =>
Create_Object (Decl);
when Iir_Kind_Interface_Package_Declaration =>
if Get_Generic_Map_Aspect_Chain (Decl) = Null_Iir then
-- Need a formal
Create_Package_Interface (Decl);
else
-- Instantiated.
Chap2.Translate_Package_Instantiation_Declaration (Decl);
end if;
when Iir_Kind_Interface_Type_Declaration
| Iir_Kinds_Interface_Subprogram_Declaration =>
null;
when others =>
Error_Kind ("translate_generic_chain", Decl);
end case;
Decl := Get_Chain (Decl);
end loop;
end Translate_Generic_Chain;
-- Create instance record for a component.
procedure Translate_Component_Declaration (Decl : Iir)
is
Mark : Id_Mark_Type;
Info : Ortho_Info_Acc;
begin
Info := Add_Info (Decl, Kind_Component);
Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
Push_Instance_Factory (Info.Comp_Scope'Access);
Info.Comp_Link := Add_Instance_Factory_Field
(Wki_Instance, Rtis.Ghdl_Component_Link_Type);
-- Generic and ports.
Translate_Generic_Chain (Decl);
Translate_Port_Chain (Decl);
Pop_Instance_Factory (Info.Comp_Scope'Access);
New_Type_Decl (Create_Identifier ("_COMPTYPE"),
Get_Scope_Type (Info.Comp_Scope));
Info.Comp_Ptr_Type := New_Access_Type
(Get_Scope_Type (Info.Comp_Scope));
New_Type_Decl (Create_Identifier ("_COMPPTR"), Info.Comp_Ptr_Type);
Pop_Identifier_Prefix (Mark);
end Translate_Component_Declaration;
procedure Translate_Declaration (Decl : Iir)
is
begin
case Get_Kind (Decl) is
when Iir_Kind_Use_Clause =>
null;
when Iir_Kind_Configuration_Specification =>
null;
when Iir_Kind_Disconnection_Specification =>
null;
when Iir_Kind_Psl_Default_Clock =>
null;
when Iir_Kind_Psl_Declaration =>
null;
when Iir_Kind_Component_Declaration =>
Chap4.Translate_Component_Declaration (Decl);
when Iir_Kind_Type_Declaration =>
-- A type declaration can be in fact a subtype declaration.
Chap4.Translate_Type_Declaration (Decl);
when Iir_Kind_Anonymous_Type_Declaration =>
Chap4.Translate_Anonymous_Type_Declaration (Decl);
when Iir_Kind_Subtype_Declaration =>
Chap4.Translate_Subtype_Declaration (Decl);
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
raise Internal_Error;
when Iir_Kind_Function_Body
| Iir_Kind_Procedure_Body =>
null;
when Iir_Kind_Protected_Type_Body =>
null;
--when Iir_Kind_Implicit_Function_Declaration =>
--when Iir_Kind_Signal_Declaration
-- | Iir_Kind_Interface_Signal_Declaration =>
-- Chap4.Create_Object (Decl);
when Iir_Kind_Variable_Declaration
| Iir_Kind_Constant_Declaration =>
Create_Object (Decl);
when Iir_Kind_Signal_Declaration =>
Create_Signal (Decl);
when Iir_Kind_Object_Alias_Declaration =>
Translate_Object_Alias_Declaration (Decl);
when Iir_Kind_Non_Object_Alias_Declaration =>
null;
when Iir_Kind_File_Declaration =>
Create_File_Object (Decl);
when Iir_Kind_Attribute_Declaration =>
-- Attribute declarations have a type mark.
null;
when Iir_Kind_Attribute_Specification =>
Chap5.Translate_Attribute_Specification (Decl);
when Iir_Kind_Signal_Attribute_Declaration =>
declare
Sig : Iir;
begin
Sig := Get_Signal_Attribute_Chain (Decl);
while Is_Valid (Sig) loop
Chap4.Create_Implicit_Signal (Sig);
Sig := Get_Attr_Chain (Sig);
end loop;
end;
when Iir_Kind_Guard_Signal_Declaration =>
Create_Signal (Decl);
when Iir_Kind_Package_Declaration =>
Chap2.Translate_Package_Declaration (Decl);
when Iir_Kind_Package_Body =>
Chap2.Translate_Package_Body (Decl);
when Iir_Kind_Package_Instantiation_Declaration =>
Chap2.Translate_Package_Instantiation_Declaration (Decl);
when Iir_Kind_Group_Template_Declaration =>
null;
when Iir_Kind_Group_Declaration =>
null;
when others =>
Error_Kind ("translate_declaration", Decl);
end case;
end Translate_Declaration;
procedure Translate_Resolution_Function (Func : Iir)
is
Finfo : constant Subprg_Info_Acc := Get_Info (Func);
Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv;
-- Type of the resolution function parameter.
El_Type : Iir;
El_Info : Type_Info_Acc;
Interface_List : O_Inter_List;
Id : O_Ident;
Itype : O_Tnode;
Unused_Instance : O_Dnode;
begin
if Rinfo = null then
-- Not a resolution function
return;
end if;
-- Declare the procedure.
Id := Create_Identifier (Func, Get_Overload_Number (Func), "_RESOLV");
Start_Procedure_Decl (Interface_List, Id, Global_Storage);
-- The instance.
if Subprgs.Has_Current_Subprg_Instance then
Subprgs.Add_Subprg_Instance_Interfaces (Interface_List,
Rinfo.Var_Instance);
else
-- Create a dummy instance parameter
New_Interface_Decl (Interface_List, Unused_Instance,
Wki_Instance, Ghdl_Ptr_Type);
Rinfo.Var_Instance := Subprgs.Null_Subprg_Instance;
end if;
-- The signal.
El_Type := Get_Type (Get_Interface_Declaration_Chain (Func));
El_Type := Get_Element_Subtype (El_Type);
El_Info := Get_Info (El_Type);
-- FIXME: create a function for getting the type of an interface.
case El_Info.Type_Mode is
when Type_Mode_Thin =>
Itype := El_Info.Ortho_Type (Mode_Signal);
when Type_Mode_Fat =>
Itype := El_Info.Ortho_Ptr_Type (Mode_Signal);
when Type_Mode_Unknown =>
raise Internal_Error;
end case;
New_Interface_Decl
(Interface_List, Rinfo.Var_Vals, Get_Identifier ("VALS"), Itype);
New_Interface_Decl
(Interface_List, Rinfo.Var_Vec, Get_Identifier ("bool_vec"),
Ghdl_Bool_Array_Ptr);
New_Interface_Decl
(Interface_List, Rinfo.Var_Vlen, Get_Identifier ("vec_len"),
Ghdl_Index_Type);
New_Interface_Decl
(Interface_List, Rinfo.Var_Nbr_Drv, Get_Identifier ("nbr_drv"),
Ghdl_Index_Type);
New_Interface_Decl
(Interface_List, Rinfo.Var_Nbr_Ports, Get_Identifier ("nbr_ports"),
Ghdl_Index_Type);
Finish_Subprogram_Decl (Interface_List, Rinfo.Resolv_Func);
end Translate_Resolution_Function;
type Read_Source_Kind is (Read_Port, Read_Driver);
type Read_Source_Data is record
Sig : Mnode;
Drv_Index : O_Dnode;
Kind : Read_Source_Kind;
end record;
procedure Read_Source_Non_Composite
(Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data)
is
Targ_Info : constant Type_Info_Acc := Get_Info (Targ_Type);
Assoc : O_Assoc_List;
E : O_Enode;
begin
case Data.Kind is
when Read_Port =>
Start_Association (Assoc, Ghdl_Signal_Read_Port);
when Read_Driver =>
Start_Association (Assoc, Ghdl_Signal_Read_Driver);
end case;
New_Association
(Assoc, New_Convert_Ov (M2E (Data.Sig), Ghdl_Signal_Ptr));
New_Association (Assoc, New_Obj_Value (Data.Drv_Index));
E := New_Convert_Ov (New_Function_Call (Assoc),
Targ_Info.Ortho_Ptr_Type (Mode_Value));
New_Assign_Stmt (M2Lv (Targ),
New_Value (New_Access_Element (E)));
end Read_Source_Non_Composite;
function Read_Source_Prepare_Data_Array
(Targ: Mnode; Targ_Type : Iir; Data : Read_Source_Data)
return Read_Source_Data
is
pragma Unreferenced (Targ, Targ_Type);
begin
return Data;
end Read_Source_Prepare_Data_Array;
function Read_Source_Prepare_Data_Record
(Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data)
return Read_Source_Data
is
pragma Unreferenced (Targ, Targ_Type);
begin
return Read_Source_Data'(Sig => Stabilize (Data.Sig),
Drv_Index => Data.Drv_Index,
Kind => Data.Kind);
end Read_Source_Prepare_Data_Record;
function Read_Source_Update_Data_Array
(Data : Read_Source_Data; Targ_Type : Iir; Index : O_Dnode)
return Read_Source_Data is
begin
return Read_Source_Data'
(Sig => Chap3.Index_Base (Data.Sig, Targ_Type,
New_Obj_Value (Index)),
Drv_Index => Data.Drv_Index,
Kind => Data.Kind);
end Read_Source_Update_Data_Array;
function Read_Source_Update_Data_Record
(Data : Read_Source_Data;
Targ_Type : Iir;
El : Iir_Element_Declaration)
return Read_Source_Data
is
pragma Unreferenced (Targ_Type);
begin
return Read_Source_Data'
(Sig => Chap6.Translate_Selected_Element (Data.Sig, El),
Drv_Index => Data.Drv_Index,
Kind => Data.Kind);
end Read_Source_Update_Data_Record;
procedure Read_Signal_Source is new Foreach_Non_Composite
(Data_Type => Read_Source_Data,
Composite_Data_Type => Read_Source_Data,
Do_Non_Composite => Read_Source_Non_Composite,
Prepare_Data_Array => Read_Source_Prepare_Data_Array,
Update_Data_Array => Read_Source_Update_Data_Array,
Prepare_Data_Record => Read_Source_Prepare_Data_Record,
Update_Data_Record => Read_Source_Update_Data_Record);
procedure Translate_Resolution_Function_Body (Func : Iir)
is
-- Type of the resolution function parameter.
Arr_Type : Iir;
Base_Type : Iir;
Base_Info : Type_Info_Acc;
Index_Info : Index_Info_Acc;
-- Type of parameter element.
El_Type : Iir;
El_Info : Type_Info_Acc;
-- Type of the function return value.
Ret_Type : Iir;
Ret_Info : Type_Info_Acc;
-- Type and info of the array index.
Index_Type : Iir;
Index_Tinfo : Type_Info_Acc;
-- Local variables.
Var_I : O_Dnode;
Var_J : O_Dnode;
Var_Length : O_Dnode;
Var_Res : O_Dnode;
Vals : Mnode;
Res : Mnode;
If_Blk : O_If_Block;
Label : O_Snode;
V : Mnode;
Var_Bound : O_Dnode;
Range_Ptr : Mnode;
Var_Array : O_Dnode;
Finfo : constant Subprg_Info_Acc := Get_Info (Func);
Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv;
Assoc : O_Assoc_List;
Data : Read_Source_Data;
begin
if Rinfo = null then
-- No resolver for this function
return;
end if;
Ret_Type := Get_Return_Type (Func);
Ret_Info := Get_Info (Ret_Type);
Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Func));
Base_Type := Get_Base_Type (Arr_Type);
Index_Info := Get_Info
(Get_Nth_Element (Get_Index_Subtype_Definition_List (Base_Type), 0));
Base_Info := Get_Info (Base_Type);
El_Type := Get_Element_Subtype (Arr_Type);
El_Info := Get_Info (El_Type);
Index_Type := Get_Index_Type (Arr_Type, 0);
Index_Tinfo := Get_Info (Index_Type);
Start_Subprogram_Body (Rinfo.Resolv_Func);
if Subprgs.Has_Subprg_Instance (Rinfo.Var_Instance) then
Subprgs.Start_Subprg_Instance_Use (Rinfo.Var_Instance);
end if;
Push_Local_Factory;
-- A signal.
New_Var_Decl
(Var_Res, Get_Identifier ("res"),
O_Storage_Local, Get_Object_Type (Ret_Info, Mode_Value));
-- I, J.
New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
New_Var_Decl (Var_J, Get_Identifier ("J"),
O_Storage_Local, Ghdl_Index_Type);
-- Length.
New_Var_Decl
(Var_Length, Wki_Length, O_Storage_Local, Ghdl_Index_Type);
New_Var_Decl (Var_Bound, Get_Identifier ("BOUND"), O_Storage_Local,
Base_Info.B.Bounds_Type);
New_Var_Decl (Var_Array, Get_Identifier ("VARRAY"), O_Storage_Local,
Base_Info.Ortho_Type (Mode_Value));
Open_Temp;
case El_Info.Type_Mode is
when Type_Mode_Thin =>
Vals := Dv2M (Rinfo.Var_Vals, El_Info, Mode_Signal);
when Type_Mode_Fat =>
Vals := Dp2M (Rinfo.Var_Vals, El_Info, Mode_Signal);
when Type_Mode_Unknown =>
raise Internal_Error;
end case;
-- * length := vec_len + nports;
New_Assign_Stmt (New_Obj (Var_Length),
New_Dyadic_Op (ON_Add_Ov,
New_Obj_Value (Rinfo.Var_Vlen),
New_Obj_Value (Rinfo.Var_Nbr_Ports)));
-- Create range from length
Range_Ptr := Lv2M (New_Selected_Element (New_Obj (Var_Bound),
Index_Info.Index_Field),
Index_Tinfo, Mode_Value,
Index_Tinfo.B.Range_Type,
Index_Tinfo.B.Range_Ptr_Type);
Chap3.Create_Range_From_Length (Index_Type, Var_Length, Range_Ptr, Func);
New_Assign_Stmt
(New_Selected_Element (New_Obj (Var_Array),
Base_Info.B.Bounds_Field (Mode_Value)),
New_Address (New_Obj (Var_Bound), Base_Info.B.Bounds_Ptr_Type));
-- Allocate the array.
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_Stack, Dv2M (Var_Array, Base_Info, Mode_Value), Base_Type);
-- Fill the array
-- 1. From ports.
-- * I := 0;
Init_Var (Var_I);
-- * loop
Start_Loop_Stmt (Label);
-- * exit when I = nports;
Gen_Exit_When (Label,
New_Compare_Op (ON_Eq,
New_Obj_Value (Var_I),
New_Obj_Value (Rinfo.Var_Nbr_Ports),
Ghdl_Bool_Type));
-- fill array[i]
V := Chap3.Index_Base
(Chap3.Get_Composite_Base (Dv2M (Var_Array, Base_Info, Mode_Value)),
Base_Type, New_Obj_Value (Var_I));
Data := Read_Source_Data'(Vals, Var_I, Read_Port);
Read_Signal_Source (V, El_Type, Data);
-- * I := I + 1;
Inc_Var (Var_I);
-- * end loop;
Finish_Loop_Stmt (Label);
-- 2. From drivers.
-- * J := 0;
-- * loop
-- * exit when j = var_max;
-- * if vec[j] then
--
-- * ptr := get_signal_driver (sig, j);
-- * array[i].XXX := *ptr
--
-- * i := i + 1;
-- * end if;
-- * J := J + 1;
-- * end loop;
Init_Var (Var_J);
Start_Loop_Stmt (Label);
Gen_Exit_When (Label,
New_Compare_Op (ON_Eq,
New_Obj_Value (Var_J),
New_Obj_Value (Rinfo.Var_Nbr_Drv),
Ghdl_Bool_Type));
Start_If_Stmt
(If_Blk,
New_Value (New_Indexed_Acc_Value (New_Obj (Rinfo.Var_Vec),
New_Obj_Value (Var_J))));
V := Chap3.Index_Base
(Chap3.Get_Composite_Base (Dv2M (Var_Array, Base_Info, Mode_Value)),
Base_Type, New_Obj_Value (Var_I));
Data := Read_Source_Data'(Vals, Var_J, Read_Driver);
Read_Signal_Source (V, El_Type, Data);
Inc_Var (Var_I);
Finish_If_Stmt (If_Blk);
Inc_Var (Var_J);
Finish_Loop_Stmt (Label);
if Finfo.Res_Interface /= O_Dnode_Null then
Res := Lo2M (Var_Res, Ret_Info, Mode_Value);
if Ret_Info.Type_Mode /= Type_Mode_Fat_Array then
Allocate_Complex_Object (Ret_Type, Alloc_Stack, Res);
end if;
end if;
-- Call the resolution function.
if Finfo.Use_Stack2 then
Create_Temp_Stack2_Mark;
end if;
Start_Association (Assoc, Finfo.Subprg_Node);
if Finfo.Res_Interface /= O_Dnode_Null then
New_Association (Assoc, M2E (Res));
end if;
Subprgs.Add_Subprg_Instance_Assoc (Assoc, Finfo.Subprg_Instance);
New_Association
(Assoc, New_Address (New_Obj (Var_Array),
Base_Info.Ortho_Ptr_Type (Mode_Value)));
if Finfo.Res_Interface = O_Dnode_Null then
Res := E2M (New_Function_Call (Assoc), Ret_Info, Mode_Value);
else
New_Procedure_Call (Assoc);
end if;
if El_Type /= Ret_Type then
Res := E2M
(Chap7.Translate_Implicit_Conv (M2E (Res), Ret_Type, El_Type,
Mode_Value, Func),
El_Info, Mode_Value);
end if;
Chap7.Set_Driving_Value (Vals, El_Type, Res);
Close_Temp;
Pop_Local_Factory;
if Subprgs.Has_Subprg_Instance (Rinfo.Var_Instance) then
Subprgs.Finish_Subprg_Instance_Use (Rinfo.Var_Instance);
end if;
Finish_Subprogram_Body;
end Translate_Resolution_Function_Body;
procedure Translate_Declaration_Chain (Parent : Iir)
is
Info : Subprg_Info_Acc;
El : Iir;
begin
El := Get_Declaration_Chain (Parent);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Procedure_Declaration
| Iir_Kind_Function_Declaration =>
-- Translate interfaces.
if not Is_Implicit_Subprogram (El)
and then (not Flag_Discard_Unused or else Get_Use_Flag (El))
and then not Is_Second_Subprogram_Specification (El)
then
Info := Add_Info (El, Kind_Subprg);
Chap2.Translate_Subprogram_Interfaces (El);
if Get_Kind (El) = Iir_Kind_Function_Declaration then
if Get_Resolution_Function_Flag (El) then
Info.Subprg_Resolv := new Subprg_Resolv_Info;
end if;
end if;
end if;
when Iir_Kind_Function_Body
| Iir_Kind_Procedure_Body =>
null;
when others =>
Translate_Declaration (El);
end case;
El := Get_Chain (El);
end loop;
end Translate_Declaration_Chain;
procedure Translate_Statements_Chain_State_Declaration
(Stmts : Iir; State_Scope : Var_Scope_Acc)
is
Num : Nat32;
Mark : Id_Mark_Type;
Locvar_Id : O_Ident;
Els : O_Element_List;
procedure Push_Prefix (Really_Push : Boolean := True)
is
Num_Img : String := Nat32'Image (Num);
begin
Num_Img (Num_Img'First) := 'S';
Locvar_Id := Get_Identifier (Num_Img);
Num := Num + 1;
if Really_Push then
Push_Identifier_Prefix (Mark, Num_Img);
end if;
end Push_Prefix;
procedure Pop_Prefix (Scope : in out Var_Scope_Type;
Really_Push : Boolean := True)
is
Locvar_Field : O_Fnode;
begin
if Really_Push then
Pop_Identifier_Prefix (Mark);
end if;
New_Union_Field
(Els, Locvar_Field, Locvar_Id, Get_Scope_Type (Scope));
Set_Scope_Via_Field (Scope, Locvar_Field, State_Scope);
end Pop_Prefix;
Info : Ortho_Info_Acc;
Stmt : Iir;
Chain : Iir;
Scope_Type : O_Tnode;
begin
Stmt := Stmts;
Start_Union_Type (Els);
Num := 0;
while Stmt /= Null_Iir loop
case Get_Kind (Stmt) is
when Iir_Kind_If_Statement =>
if Get_Suspend_Flag (Stmt) then
Chain := Stmt;
while Chain /= Null_Iir loop
Push_Prefix;
Info := Add_Info (Chain, Kind_Locvar_State);
Translate_Statements_Chain_State_Declaration
(Get_Sequential_Statement_Chain (Chain),
Info.Locvar_Scope'Access);
Pop_Prefix (Info.Locvar_Scope);
Chain := Get_Else_Clause (Chain);
end loop;
end if;
when Iir_Kind_Case_Statement =>
if Get_Suspend_Flag (Stmt) then
Chain := Get_Case_Statement_Alternative_Chain (Stmt);
while Chain /= Null_Iir loop
if not Get_Same_Alternative_Flag (Chain) then
Push_Prefix;
Info := Add_Info (Chain, Kind_Locvar_State);
Translate_Statements_Chain_State_Declaration
(Get_Associated_Chain (Chain),
Info.Locvar_Scope'Access);
Pop_Prefix (Info.Locvar_Scope);
end if;
Chain := Get_Chain (Chain);
end loop;
end if;
when Iir_Kind_While_Loop_Statement =>
if Get_Suspend_Flag (Stmt) then
Push_Prefix;
Info := Add_Info (Stmt, Kind_Loop_State);
Translate_Statements_Chain_State_Declaration
(Get_Sequential_Statement_Chain (Stmt),
Info.Loop_Locvar_Scope'Access);
Pop_Prefix (Info.Loop_Locvar_Scope);
end if;
when Iir_Kind_For_Loop_Statement =>
if Get_Suspend_Flag (Stmt) then
Push_Prefix;
Info := Add_Info (Stmt, Kind_Loop_State);
Push_Instance_Factory (Info.Loop_State_Scope'Access);
Chap8.Translate_For_Loop_Statement_Declaration (Stmt);
Translate_Statements_Chain_State_Declaration
(Get_Sequential_Statement_Chain (Stmt),
Info.Loop_Locvar_Scope'Access);
Add_Scope_Field (Wki_Locvars, Info.Loop_Locvar_Scope);
Pop_Instance_Factory (Info.Loop_State_Scope'Access);
New_Type_Decl (Create_Identifier ("FORTYPE"),
Get_Scope_Type (Info.Loop_State_Scope));
Pop_Prefix (Info.Loop_State_Scope);
end if;
when Iir_Kind_Procedure_Call_Statement =>
declare
Call : constant Iir := Get_Procedure_Call (Stmt);
Imp : constant Iir := Get_Implementation (Call);
begin
Vhdl.Canon.Canon_Subprogram_Call (Call);
Update_Node_Infos;
if Get_Suspend_Flag (Imp) then
Push_Prefix;
Info := Add_Info (Call, Kind_Call);
Chap8.Translate_Procedure_Call_State (Call);
Pop_Prefix (Info.Call_State_Scope);
end if;
end;
when others =>
null;
end case;
Stmt := Get_Chain (Stmt);
end loop;
Finish_Union_Type (Els, Scope_Type);
New_Type_Decl
(Create_Identifier ("LOCVARTYPE"), Scope_Type);
Create_Union_Scope (State_Scope.all, Scope_Type);
end Translate_Statements_Chain_State_Declaration;
procedure Translate_Declaration_Chain_Subprograms
(Parent : Iir; What : Subprg_Translate_Kind)
is
-- True iff specs must be translated.
Do_Specs : constant Boolean := What in Subprg_Translate_Spec;
-- True iff bodies must be translated.
Do_Bodies : constant Boolean :=
(What in Subprg_Translate_Body
and then Global_Storage /= O_Storage_External);
El : Iir;
Infos : Chap7.Implicit_Subprogram_Infos;
begin
El := Get_Declaration_Chain (Parent);
while El /= Null_Iir loop
case Get_Kind (El) is
when Iir_Kind_Procedure_Declaration
| Iir_Kind_Function_Declaration =>
if Is_Implicit_Subprogram (El) then
if Flag_Discard_Unused_Implicit
and then not Get_Use_Flag (El)
then
case Get_Implicit_Definition (El) is
when Iir_Predefined_Array_Equality
| Iir_Predefined_Array_Greater
| Iir_Predefined_Record_Equality =>
-- Used implicitly in case statement or other
-- predefined equality.
if Do_Specs then
Chap7.Translate_Implicit_Subprogram_Spec
(El, Infos);
end if;
if Do_Bodies then
Chap7.Translate_Implicit_Subprogram_Body (El);
end if;
when others =>
null;
end case;
else
if Do_Specs then
Chap7.Translate_Implicit_Subprogram_Spec
(El, Infos);
end if;
if Do_Bodies then
Chap7.Translate_Implicit_Subprogram_Body (El);
end if;
end if;
else
-- Translate only if used.
if Do_Specs and then Get_Info (El) /= null then
Chap2.Translate_Subprogram_Declaration (El);
Translate_Resolution_Function (El);
end if;
end if;
when Iir_Kind_Function_Body
| Iir_Kind_Procedure_Body =>
if Do_Bodies then
-- Do not translate body if generating only specs (for
-- subprograms in an entity).
if not Flag_Discard_Unused
or else
Get_Use_Flag (Get_Subprogram_Specification (El))
then
Chap2.Translate_Subprogram_Body (El);
Translate_Resolution_Function_Body
(Get_Subprogram_Specification (El));
end if;
end if;
when Iir_Kind_Type_Declaration
| Iir_Kind_Anonymous_Type_Declaration =>
Chap3.Translate_Type_Subprograms (El, What);
Chap7.Init_Implicit_Subprogram_Infos (Infos);
when Iir_Kind_Protected_Type_Body =>
if Do_Specs then
Chap3.Translate_Protected_Type_Body (El);
end if;
if Do_Bodies then
Chap3.Translate_Protected_Type_Body_Subprograms_Spec (El);
Chap3.Translate_Protected_Type_Body_Subprograms_Body (El);
end if;
when Iir_Kind_Package_Declaration
| Iir_Kind_Package_Body =>
declare
Mark : Id_Mark_Type;
begin
Push_Identifier_Prefix (Mark, Get_Identifier (El));
Translate_Declaration_Chain_Subprograms (El, What);
Pop_Identifier_Prefix (Mark);
end;
when Iir_Kind_Package_Instantiation_Declaration =>
if Get_Macro_Expanded_Flag
(Get_Uninstantiated_Package_Decl (El))
then
declare
Bod : constant Iir := Get_Instance_Package_Body (El);
Mark : Id_Mark_Type;
begin
Push_Identifier_Prefix (Mark, Get_Identifier (El));
Translate_Declaration_Chain_Subprograms (El, What);
if Is_Valid (Bod)
and then Global_Storage /= O_Storage_External
then
Translate_Declaration_Chain_Subprograms (Bod, What);
end if;
Pop_Identifier_Prefix (Mark);
end;
end if;
when others =>
null;
end case;
El := Get_Chain (El);
end loop;
end Translate_Declaration_Chain_Subprograms;
procedure Elab_Declaration_Chain (Parent : Iir; Need_Final : out Boolean)
is
Decl : Iir;
begin
Decl := Get_Declaration_Chain (Parent);
Need_Final := False;
while Decl /= Null_Iir loop
case Get_Kind (Decl) is
when Iir_Kind_Use_Clause =>
null;
when Iir_Kind_Component_Declaration =>
null;
when Iir_Kind_Configuration_Specification =>
null;
when Iir_Kind_Disconnection_Specification =>
Chap5.Elab_Disconnection_Specification (Decl);
when Iir_Kind_Type_Declaration
| Iir_Kind_Anonymous_Type_Declaration =>
Chap3.Elab_Type_Declaration (Decl);
when Iir_Kind_Subtype_Declaration =>
Chap3.Elab_Subtype_Declaration (Decl);
when Iir_Kind_Protected_Type_Body =>
null;
--when Iir_Kind_Signal_Declaration =>
-- Chap1.Elab_Signal (Decl);
when Iir_Kind_Variable_Declaration
| Iir_Kind_Constant_Declaration =>
-- Do not call Open_Temp/Close_Temp, as objects may be created
-- using alloca (which has a scope life) or on the secondary
-- stack.
Elab_Object (Decl);
if Get_Kind (Get_Type (Decl))
= Iir_Kind_Protected_Type_Declaration
then
Need_Final := True;
end if;
when Iir_Kind_Signal_Declaration =>
Elab_Signal_Declaration (Decl, Parent, False);
when Iir_Kind_Object_Alias_Declaration =>
Elab_Object_Alias_Declaration (Decl);
when Iir_Kind_Non_Object_Alias_Declaration =>
null;
when Iir_Kind_File_Declaration =>
Elab_File_Declaration (Decl);
Need_Final := True;
when Iir_Kind_Attribute_Declaration =>
-- An attribute declaration can only have a type mark.
null;
when Iir_Kind_Attribute_Specification =>
Chap5.Elab_Attribute_Specification (Decl);
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
if not Is_Implicit_Subprogram (Decl)
and then Get_Info (Decl) /= null
then
Chap2.Elab_Subprogram_Interfaces (Decl);
end if;
when Iir_Kind_Function_Body
| Iir_Kind_Procedure_Body =>
null;
when Iir_Kind_Signal_Attribute_Declaration =>
declare
Sig : Iir;
begin
Sig := Get_Signal_Attribute_Chain (Decl);
while Is_Valid (Sig) loop
case Iir_Kinds_Signal_Attribute (Get_Kind (Sig)) is
when Iir_Kind_Stable_Attribute
| Iir_Kind_Quiet_Attribute
| Iir_Kind_Transaction_Attribute =>
Elab_Signal_Attribute (Sig);
when Iir_Kind_Delayed_Attribute =>
Elab_Signal_Delayed_Attribute (Sig);
end case;
Sig := Get_Attr_Chain (Sig);
end loop;
end;
when Iir_Kind_Group_Template_Declaration
| Iir_Kind_Group_Declaration =>
null;
when Iir_Kind_Package_Declaration =>
Chap2.Elab_Package (Decl, Get_Package_Header (Decl));
-- FIXME: finalizer
when Iir_Kind_Package_Body =>
declare
Nested_Final : Boolean;
begin
Elab_Declaration_Chain (Decl, Nested_Final);
Need_Final := Need_Final or Nested_Final;
end;
when Iir_Kind_Package_Instantiation_Declaration =>
-- FIXME: finalizers ?
Chap2.Elab_Package_Instantiation_Declaration (Decl);
when Iir_Kind_Psl_Default_Clock =>
null;
when Iir_Kind_Psl_Declaration =>
null;
when others =>
Error_Kind ("elab_declaration_chain", Decl);
end case;
Decl := Get_Chain (Decl);
end loop;
end Elab_Declaration_Chain;
procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean)
is
Decl : Iir;
begin
Decl := Get_Declaration_Chain (Parent);
while Decl /= Null_Iir loop
case Get_Kind (Decl) is
when Iir_Kind_File_Declaration =>
Final_File_Declaration (Decl);
when Iir_Kind_Variable_Declaration =>
if Get_Kind (Get_Type (Decl))
= Iir_Kind_Protected_Type_Declaration
then
Fini_Protected_Object (Decl);
end if;
if Deallocate then
Fini_Object (Decl);
end if;
when Iir_Kind_Constant_Declaration =>
if Deallocate then
Fini_Object (Decl);
end if;
when others =>
null;
end case;
Decl := Get_Chain (Decl);
end loop;
end Final_Declaration_Chain;
type Conv_Mode is (Conv_Mode_In, Conv_Mode_Out);
-- Create subprogram for an association conversion.
-- STMT is the statement/block_header containing the association.
-- BLOCK is the architecture/block containing the instance.
-- ASSOC is the association and MODE the conversion to work on.
-- CONV_INFO is the result place holder.
-- BASE_BLOCK is the base architecture/block containing the instance.
-- ENTITY is the entity/component instantiated (null for block_stmt)
procedure Translate_Association_Subprogram
(Stmt : Iir;
Block : Iir;
Assoc : Iir;
Inter : Iir;
Mode : Conv_Mode;
Conv_Info : in out Assoc_Conv_Info;
Num : Iir_Int32;
Base_Block : Iir;
Entity : Iir)
is
Formal : constant Iir := Get_Association_Formal (Assoc, Inter);
Actual : constant Iir := Get_Actual (Assoc);
Block_Info : constant Block_Info_Acc := Get_Info (Base_Block);
Mark2, Mark3 : Id_Mark_Type;
Inter_List : O_Inter_List;
In_Type, Out_Type : Iir;
In_Info, Out_Info : Type_Info_Acc;
El_List : O_Element_List;
Stmt_Info : Block_Info_Acc;
Entity_Info : Ortho_Info_Acc;
Var_Data : O_Dnode;
-- Variables for body.
E : O_Enode;
V : O_Dnode;
V1 : O_Lnode;
V_Out : Mnode;
R : O_Enode;
Constr : O_Assoc_List;
Subprg_Info : Subprg_Info_Acc;
Res : Mnode;
M1 : Mnode;
Imp : Iir;
Func : Iir;
Obj : Iir; -- Method object for function conversion
Obj_Type : Iir; -- Valid only if OBJ is valid
begin
case Mode is
when Conv_Mode_In =>
-- IN: from actual to formal.
Push_Identifier_Prefix (Mark2, "CONVIN");
Out_Type := Get_Type (Formal);
In_Type := Get_Type (Actual);
Imp := Get_Actual_Conversion (Assoc);
when Conv_Mode_Out =>
-- OUT: from formal to actual.
Push_Identifier_Prefix (Mark2, "CONVOUT");
In_Type := Get_Type (Formal);
Out_Type := Get_Type (Actual);
Imp := Get_Formal_Conversion (Assoc);
end case;
-- Add interface name and a unique number in case of individual assoc.
Push_Identifier_Prefix (Mark3, Get_Identifier (Inter), Num);
-- Handle anonymous subtypes.
Chap3.Translate_Anonymous_Subtype_Definition (Out_Type, False);
Chap3.Translate_Anonymous_Subtype_Definition (In_Type, False);
Out_Info := Get_Info (Out_Type);
In_Info := Get_Info (In_Type);
if Get_Kind (Imp) = Iir_Kind_Function_Call then
Obj := Get_Method_Object (Imp);
if Is_Valid (Obj) then
Obj_Type := Get_Type (Obj);
end if;
else
Obj := Null_Iir;
end if;
-- Start record containing data for the conversion function.
Start_Record_Type (El_List);
-- Add instance field.
Conv_Info.Instance_Block := Base_Block;
New_Record_Field
(El_List, Conv_Info.Instance_Field, Wki_Instance,
Block_Info.Block_Decls_Ptr_Type);
-- Add instance field for the entity in case of direct instantiation.
if Entity /= Null_Iir then
Conv_Info.Instantiated_Entity := Entity;
Entity_Info := Get_Info (Entity);
declare
Ptr : O_Tnode;
begin
if Entity_Info.Kind = Kind_Component then
Ptr := Entity_Info.Comp_Ptr_Type;
else
Ptr := Entity_Info.Block_Decls_Ptr_Type;
end if;
New_Record_Field
(El_List, Conv_Info.Instantiated_Field,
Get_Identifier ("instantiated"), Ptr);
end;
else
Conv_Info.Instantiated_Entity := Null_Iir;
Conv_Info.Instantiated_Field := O_Fnode_Null;
end if;
if Obj /= Null_Iir then
New_Record_Field
(El_List, Conv_Info.Method_Object, Get_Identifier ("obj"),
Get_Info (Obj_Type).Ortho_Ptr_Type (Mode_Value));
else
Conv_Info.Method_Object := O_Fnode_Null;
end if;
-- Add inputs, which is a pointer to the signal.
New_Record_Field
(El_List, Conv_Info.In_Sig_Field, Get_Identifier ("sig_in"),
Get_Object_Ptr_Type (In_Info, Mode_Signal));
New_Record_Field
(El_List, Conv_Info.In_Val_Field, Get_Identifier ("val_in"),
Get_Object_Ptr_Type (In_Info, Mode_Value));
-- Add output.
New_Record_Field
(El_List, Conv_Info.Out_Sig_Field, Get_Identifier ("sig_out"),
Get_Object_Type (Out_Info, Mode_Signal));
New_Record_Field
(El_List, Conv_Info.Out_Val_Field, Get_Identifier ("val_out"),
Get_Object_Type (Out_Info, Mode_Value));
Finish_Record_Type (El_List, Conv_Info.Record_Type);
New_Type_Decl (Create_Identifier ("DTYPE"), Conv_Info.Record_Type);
Conv_Info.Record_Ptr_Type := New_Access_Type (Conv_Info.Record_Type);
New_Type_Decl (Create_Identifier ("DPTR"), Conv_Info.Record_Ptr_Type);
-- Declare the subprogram.
Start_Procedure_Decl
(Inter_List, Create_Identifier, O_Storage_Private);
New_Interface_Decl
(Inter_List, Var_Data, Get_Identifier ("data"),
Conv_Info.Record_Ptr_Type);
Finish_Subprogram_Decl (Inter_List, Conv_Info.Subprg);
Start_Subprogram_Body (Conv_Info.Subprg);
Push_Local_Factory;
Open_Temp;
-- Add an access to local block.
V := Create_Temp_Init
(Block_Info.Block_Decls_Ptr_Type,
New_Value_Selected_Acc_Value (New_Obj (Var_Data),
Conv_Info.Instance_Field));
Set_Scope_Via_Param_Ptr (Block_Info.Block_Scope, V);
-- Add an access to instantiated entity.
-- This may be used to do some type checks.
if Conv_Info.Instantiated_Entity /= Null_Iir then
declare
Ptr_Type : O_Tnode;
begin
if Entity_Info.Kind = Kind_Component then
Ptr_Type := Entity_Info.Comp_Ptr_Type;
else
Ptr_Type := Entity_Info.Block_Decls_Ptr_Type;
end if;
V := Create_Temp_Init
(Ptr_Type,
New_Value_Selected_Acc_Value (New_Obj (Var_Data),
Conv_Info.Instantiated_Field));
if Entity_Info.Kind = Kind_Component then
Set_Scope_Via_Param_Ptr (Entity_Info.Comp_Scope, V);
else
Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, V);
end if;
end;
end if;
-- Add access to the instantiation-specific data.
-- This is used only for anonymous subtype variables.
-- FIXME: what if STMT is a binding_indication ?
Stmt_Info := Get_Info (Stmt);
if Stmt_Info /= null
and then Has_Scope_Type (Stmt_Info.Block_Scope)
then
Set_Scope_Via_Field (Stmt_Info.Block_Scope,
Stmt_Info.Block_Parent_Field,
Get_Info (Block).Block_Scope'Access);
end if;
-- Read signal value.
case Mode is
when Conv_Mode_In =>
V1 := New_Selected_Acc_Value (New_Obj (Var_Data),
Conv_Info.In_Val_Field);
R := M2E (Lop2M (V1, In_Info, Mode_Value));
when Conv_Mode_Out =>
V1 := New_Selected_Acc_Value (New_Obj (Var_Data),
Conv_Info.In_Sig_Field);
M1 := Lop2M (V1, In_Info, Mode_Signal);
M1 := Chap7.Translate_Signal_Driving_Value (M1, In_Type);
R := M2E (M1);
end case;
case Get_Kind (Imp) is
when Iir_Kind_Function_Call =>
Func := Get_Implementation (Imp);
R := Chap7.Translate_Implicit_Conv
(R, In_Type,
Get_Type (Get_Interface_Declaration_Chain (Func)),
Mode_Value, Assoc);
-- Create result value.
Subprg_Info := Get_Info (Func);
if Subprg_Info.Use_Stack2 then
Create_Temp_Stack2_Mark;
end if;
if Subprg_Info.Res_Interface /= O_Dnode_Null then
-- Composite result.
-- If we need to allocate, do it before starting the call!
declare
Res_Type : constant Iir := Get_Return_Type (Func);
Res_Info : constant Type_Info_Acc := Get_Info (Res_Type);
begin
Res := Create_Temp (Res_Info);
if Res_Info.Type_Mode /= Type_Mode_Fat_Array then
Chap4.Allocate_Complex_Object
(Res_Type, Alloc_Stack, Res);
end if;
end;
end if;
-- Call conversion function.
Start_Association (Constr, Subprg_Info.Subprg_Node);
if Subprg_Info.Res_Interface /= O_Dnode_Null then
-- Composite result.
New_Association (Constr, M2E (Res));
end if;
if Obj /= Null_Iir then
-- Protected object.
New_Association
(Constr,
New_Value (New_Selected_Acc_Value
(New_Obj (Var_Data),
Conv_Info.Method_Object)));
else
Subprgs.Add_Subprg_Instance_Assoc
(Constr, Subprg_Info.Subprg_Instance);
end if;
New_Association (Constr, R);
if Subprg_Info.Res_Interface /= O_Dnode_Null then
-- Composite result.
New_Procedure_Call (Constr);
E := M2E (Res);
else
E := New_Function_Call (Constr);
end if;
Res := E2M
(Chap7.Translate_Implicit_Conv (E, Get_Return_Type (Func),
Out_Type, Mode_Value, Imp),
Get_Info (Out_Type), Mode_Value);
when Iir_Kind_Type_Conversion =>
declare
Conv_Type : constant Iir := Get_Type (Imp);
begin
E := Chap7.Translate_Type_Conversion
(R, In_Type, Conv_Type, Assoc);
E := Chap7.Translate_Implicit_Conv
(E, Conv_Type, Out_Type, Mode_Value, Imp);
Res := E2M (E, Get_Info (Out_Type), Mode_Value);
end;
when others =>
Error_Kind ("Translate_Association_Subprogram", Imp);
end case;
-- Assign signals.
case Mode is
when Conv_Mode_In =>
V1 := New_Selected_Acc_Value (New_Obj (Var_Data),
Conv_Info.Out_Val_Field);
V_Out := Lo2M (V1, Out_Info, Mode_Value);
Chap7.Translate_Assign (V_Out, M2E (Res), Formal, Out_Type, Assoc);
when Conv_Mode_Out =>
V1 := New_Selected_Acc_Value (New_Obj (Var_Data),
Conv_Info.Out_Sig_Field);
V_Out := Lo2M (V1, Out_Info, Mode_Signal);
Chap7.Set_Driving_Value (V_Out, Out_Type, Res);
end case;
Close_Temp;
if Stmt_Info /= null
and then Has_Scope_Type (Stmt_Info.Block_Scope)
then
Clear_Scope (Stmt_Info.Block_Scope);
end if;
if Conv_Info.Instantiated_Entity /= Null_Iir then
if Entity_Info.Kind = Kind_Component then
Clear_Scope (Entity_Info.Comp_Scope);
else
Clear_Scope (Entity_Info.Block_Scope);
end if;
end if;
Clear_Scope (Block_Info.Block_Scope);
Pop_Local_Factory;
Finish_Subprogram_Body;
Pop_Identifier_Prefix (Mark3);
Pop_Identifier_Prefix (Mark2);
end Translate_Association_Subprogram;
procedure Translate_Inertial_Subprogram
(Stmt : Iir;
Block : Iir;
Assoc : Iir;
Inter : Iir;
Num : Iir_Int32;
Base_Block : Iir;
Entity : Iir)
is
pragma Unreferenced (Num);
Formal : constant Iir := Get_Association_Formal (Assoc, Inter);
Actual : constant Iir := Get_Actual (Assoc);
Block_Info : constant Block_Info_Acc := Get_Info (Base_Block);
Assoc_Info : Inertial_Info_Acc;
Inter_List : O_Inter_List;
Entity_Info : Ortho_Info_Acc;
Targ : Mnode;
Val : Mnode;
begin
-- Declare the subprogram.
Assoc_Info := Add_Info (Assoc, Kind_Inertial_Assoc);
Start_Procedure_Decl
(Inter_List, Create_Identifier (Inter, "INERTIAL"),
O_Storage_Private);
New_Interface_Decl (Inter_List, Assoc_Info.Inertial_Inst,
Wki_Instance, Block_Info.Block_Decls_Ptr_Type);
Finish_Subprogram_Decl (Inter_List, Assoc_Info.Inertial_Proc);
-- The body.
New_Debug_Line_Decl (Get_Line_Number (Assoc));
Start_Subprogram_Body (Assoc_Info.Inertial_Proc);
Push_Local_Factory;
-- Access for actual.
Assoc_Info.Inertial_Block := Base_Block;
Set_Scope_Via_Param_Ptr (Block_Info.Block_Scope,
Assoc_Info.Inertial_Inst);
Open_Temp;
-- Access for formals.
if Entity /= Null_Iir then
Entity_Info := Get_Info (Entity);
declare
Inst_Info : constant Block_Info_Acc := Get_Info (Stmt);
V : O_Dnode;
begin
if Entity_Info.Kind = Kind_Component then
Set_Scope_Via_Field (Entity_Info.Comp_Scope,
Inst_Info.Block_Link_Field,
Block_Info.Block_Scope'Access);
else
-- Get access to the directly instantiated entity through
-- the link. The link is a __ghdl_component_link_type which
-- points to the __ghdl_entity_link_type of the entity.
V := Create_Temp_Init
(Entity_Info.Block_Decls_Ptr_Type,
New_Convert_Ov
(New_Value
(New_Selected_Element
(New_Selected_Element
(New_Access_Element (Get_Instance_Access (Block)),
Inst_Info.Block_Link_Field),
Rtis.Ghdl_Component_Link_Instance)),
Entity_Info.Block_Decls_Ptr_Type));
Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, V);
end if;
end;
end if;
-- Access for formal.
-- 1. Translate target (translate_name)
Targ := Chap6.Translate_Name (Formal, Mode_Signal);
-- 2. Translate expression
Val := Chap7.Translate_Expression (Actual, Get_Type (Formal));
-- 3. Check bounds match
-- TODO
-- 4. Call Gen_Simple_Signal_Assign
Chap8.Translate_Inertial_Assignment
(Targ, Get_Type (Formal), Val, Assoc);
-- Set_Map_Env (Formal_Env);
if Entity /= Null_Iir then
if Entity_Info.Kind = Kind_Component then
Clear_Scope (Entity_Info.Comp_Scope);
else
Clear_Scope (Entity_Info.Block_Scope);
end if;
end if;
Close_Temp;
Clear_Scope (Block_Info.Block_Scope);
Pop_Local_Factory;
Finish_Subprogram_Body;
end Translate_Inertial_Subprogram;
-- Create subprograms for associations: conversions and inertial assocs.
-- ENTITY is null for block_statement.
procedure Translate_Association_Subprograms
(Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir)
is
Assoc : Iir;
Assoc_Inter : Iir;
Inter : Iir;
Info : Assoc_Info_Acc;
Num : Iir_Int32;
begin
Assoc := Get_Port_Map_Aspect_Chain (Stmt);
Num := 0;
if Is_Null (Entity) then
Assoc_Inter := Get_Port_Chain (Stmt);
else
Assoc_Inter := Get_Port_Chain (Entity);
end if;
while Assoc /= Null_Iir loop
Inter := Get_Association_Interface (Assoc, Assoc_Inter);
case Get_Kind (Assoc) is
when Iir_Kind_Association_Element_By_Name =>
Info := null;
if Get_Actual_Conversion (Assoc) /= Null_Iir then
Info := Add_Info (Assoc, Kind_Assoc);
Translate_Association_Subprogram
(Stmt, Block, Assoc, Inter, Conv_Mode_In, Info.Assoc_In,
Num, Base_Block, Entity);
Num := Num + 1;
end if;
if Get_Formal_Conversion (Assoc) /= Null_Iir then
if Info = null then
Info := Add_Info (Assoc, Kind_Assoc);
end if;
Translate_Association_Subprogram
(Stmt, Block, Assoc, Inter, Conv_Mode_Out, Info.Assoc_Out,
Num, Base_Block, Entity);
Num := Num + 1;
end if;
when Iir_Kind_Association_Element_By_Expression =>
if Get_Expr_Staticness (Get_Actual (Assoc)) = None then
Translate_Inertial_Subprogram
(Stmt, Block, Assoc, Inter, Num, Base_Block, Entity);
end if;
when Iir_Kind_Association_Element_By_Individual
| Iir_Kind_Association_Element_Open =>
null;
when others =>
Error_Kind ("translate_association_subprograms", Assoc);
end case;
Next_Association_Interface (Assoc, Assoc_Inter);
end loop;
end Translate_Association_Subprograms;
-- Register conversion CONV in association between SIG_IN and SIG_OUT.
-- This procedure allocates a record data (described by INFO), fill it
-- with addresses of signals and register it to REG_SUBPRG.
procedure Elab_Conversion (Sig_In : Iir;
Sig_Out : Iir;
Conv : Iir;
Reg_Subprg : O_Dnode;
Info : Assoc_Conv_Info;
Dest_Sig : out Mnode)
is
Out_Type : constant Iir := Get_Type (Sig_Out);
Out_Info : constant Type_Info_Acc := Get_Info (Out_Type);
In_Type : constant Iir := Get_Type (Sig_In);
In_Info : constant Type_Info_Acc := Get_Info (In_Type);
Src_Sig : Mnode;
Src_Val : Mnode;
Dest_Val : Mnode;
Constr : O_Assoc_List;
Var_Data : O_Dnode;
Data : Elab_Signal_Data;
begin
-- Allocate data for the subprogram.
Var_Data := Create_Temp (Info.Record_Ptr_Type);
New_Assign_Stmt
(New_Obj (Var_Data),
Gen_Alloc (Alloc_System,
New_Lit (New_Sizeof (Info.Record_Type, Ghdl_Index_Type)),
Info.Record_Ptr_Type));
-- Set instance.
New_Assign_Stmt
(New_Selected_Acc_Value (New_Obj (Var_Data), Info.Instance_Field),
Get_Instance_Access (Info.Instance_Block));
-- Set instantiated unit instance (if any).
if Info.Instantiated_Entity /= Null_Iir then
declare
Inst_Addr : O_Enode;
Inst_Info : Ortho_Info_Acc;
begin
if Get_Kind (Info.Instantiated_Entity)
= Iir_Kind_Component_Declaration
then
Inst_Info := Get_Info (Info.Instantiated_Entity);
Inst_Addr := New_Address
(Get_Instance_Ref (Inst_Info.Comp_Scope),
Inst_Info.Comp_Ptr_Type);
else
Inst_Addr := Get_Instance_Access (Info.Instantiated_Entity);
end if;
New_Assign_Stmt
(New_Selected_Acc_Value (New_Obj (Var_Data),
Info.Instantiated_Field),
Inst_Addr);
end;
end if;
if Info.Method_Object /= O_Fnode_Null then
New_Assign_Stmt
(New_Selected_Acc_Value (New_Obj (Var_Data),
Info.Method_Object),
M2E (Chap6.Translate_Name
(Get_Method_Object (Conv), Mode_Value)));
end if;
-- Set input.
Chap6.Translate_Signal_Name (Sig_In, Src_Sig, Src_Val);
Src_Sig := Stabilize (Src_Sig, True);
Assign_Obj_Ptr (Lop2M (New_Selected_Acc_Value (New_Obj (Var_Data),
Info.In_Sig_Field),
In_Info, Mode_Signal),
Src_Sig);
Assign_Obj_Ptr (Lop2M (New_Selected_Acc_Value (New_Obj (Var_Data),
Info.In_Val_Field),
In_Info, Mode_Value),
Src_Val);
-- Create a copy of SIG_OUT.
Dest_Sig := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data),
Info.Out_Sig_Field),
Out_Info, Mode_Signal);
Chap4.Allocate_Complex_Object (Out_Type, Alloc_System, Dest_Sig);
Dest_Val := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data),
Info.Out_Val_Field),
Out_Info, Mode_Value);
Chap4.Allocate_Complex_Object (Out_Type, Alloc_System, Dest_Val);
-- Note: NDEST will be assigned by ELAB_SIGNAL.
Dest_Sig := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data),
Info.Out_Sig_Field),
Out_Info, Mode_Signal);
Dest_Val := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data),
Info.Out_Val_Field),
Out_Info, Mode_Value);
Data := Elab_Signal_Data'(Value => Dest_Val,
Has_Val => False,
Already_Resolved => True,
Init_Val => Mnode_Null,
Check_Null => False,
If_Stmt => null);
Elab_Signal (Dest_Sig, Out_Type, Data);
Dest_Sig := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data),
Info.Out_Sig_Field),
Out_Info, Mode_Signal);
Dest_Sig := Stabilize (Dest_Sig, True);
-- Register.
Start_Association (Constr, Reg_Subprg);
New_Association
(Constr, New_Lit (New_Subprogram_Address (Info.Subprg,
Ghdl_Ptr_Type)));
New_Association
(Constr, New_Convert_Ov (New_Obj_Value (Var_Data), Ghdl_Ptr_Type));
New_Association
(Constr,
New_Convert_Ov (M2E (Get_Leftest_Signal (Src_Sig, Get_Type (Sig_In))),
Ghdl_Signal_Ptr));
New_Association
(Constr, Get_Nbr_Signals (Src_Sig, Get_Type (Sig_In)));
New_Association
(Constr,
New_Convert_Ov (M2E (Get_Leftest_Signal (Dest_Sig,
Get_Type (Sig_Out))),
Ghdl_Signal_Ptr));
New_Association
(Constr, Get_Nbr_Signals (Dest_Sig, Get_Type (Sig_Out)));
New_Procedure_Call (Constr);
end Elab_Conversion;
-- In conversion: from actual to formal.
procedure Elab_In_Conversion (Assoc : Iir; Formal : Iir; Ndest : out Mnode)
is
Assoc_Info : constant Assoc_Info_Acc := Get_Info (Assoc);
begin
Elab_Conversion
(Get_Actual (Assoc), Formal, Get_Actual_Conversion (Assoc),
Ghdl_Signal_In_Conversion, Assoc_Info.Assoc_In, Ndest);
end Elab_In_Conversion;
-- Out conversion: from formal to actual.
procedure Elab_Out_Conversion (Assoc : Iir; Formal : Iir; Ndest : out Mnode)
is
-- Note: because it's an out conversion, the formal of ASSOC is set.
-- Still pass INTER for coherence with Elab_In_Conversion.
Assoc_Info : constant Assoc_Info_Acc := Get_Info (Assoc);
begin
Elab_Conversion
(Formal, Get_Actual (Assoc), Get_Formal_Conversion (Assoc),
Ghdl_Signal_Out_Conversion, Assoc_Info.Assoc_Out, Ndest);
end Elab_Out_Conversion;
-- Create a record that describe thes location of an IIR node and
-- returns the address of it.
function Get_Location (N : Iir) return O_Dnode
is
Constr : O_Record_Aggr_List;
Aggr : O_Cnode;
Name : Name_Id;
Line : Natural;
Col : Natural;
C : O_Dnode;
begin
Files_Map.Location_To_Position (Get_Location (N), Name, Line, Col);
New_Const_Decl (C, Create_Uniq_Identifier, O_Storage_Private,
Ghdl_Location_Type_Node);
Start_Init_Value (C);
Start_Record_Aggr (Constr, Ghdl_Location_Type_Node);
New_Record_Aggr_El
(Constr, New_Global_Address (New_Global (Current_Filename_Node),
Char_Ptr_Type));
New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type,
Integer_64 (Line)));
New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type,
Integer_64 (Col)));
Finish_Record_Aggr (Constr, Aggr);
Finish_Init_Value (C, Aggr);
return C;
--return New_Global_Address (C, Ghdl_Location_Ptr_Node);
end Get_Location;
end Trans.Chap4;