diff options
60 files changed, 2109 insertions, 1508 deletions
diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb index 065d64ef1..1a6239f1a 100644 --- a/src/grt/grt-avhpi.adb +++ b/src/grt/grt-avhpi.adb @@ -151,10 +151,12 @@ package body Grt.Avhpi is Bt : constant Ghdl_Rtin_Type_Array_Acc := To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + Layout : Address; begin + Layout := + Loc_To_Addr (St.Common.Depth, St.Layout, Res.Ctxt); Bound_To_Range - (Loc_To_Addr (St.Common.Depth, St.Bounds, Res.Ctxt), - Bt, Rngs); + (Array_Layout_To_Bounds (Layout), Bt, Rngs); Res.N_Idx := Ranges_To_Length (Rngs, Bt.Indexes); end; when others => @@ -176,7 +178,6 @@ package body Grt.Avhpi is El_Type : Ghdl_Rti_Access; Off : Ghdl_Index_Type) return Address is - pragma Unreferenced (Ctxt); Is_Sig : Boolean; El_Size : Ghdl_Index_Type; El_Type1 : Ghdl_Rti_Access; @@ -202,13 +203,20 @@ package body Grt.Avhpi is El_Size := Ghdl_I64'Size / Storage_Unit; end if; when Ghdl_Rtik_Subtype_Array => - if Is_Sig then - El_Size := Ghdl_Index_Type - (To_Ghdl_Rtin_Subtype_Composite_Acc (El_Type1).Sigsize); - else - El_Size := Ghdl_Index_Type - (To_Ghdl_Rtin_Subtype_Composite_Acc (El_Type1).Valsize); - end if; + declare + Sizes : Ghdl_Indexes_Ptr; + begin + Sizes := To_Ghdl_Indexes_Ptr + (Loc_To_Addr + (El_Type1.Depth, + To_Ghdl_Rtin_Subtype_Composite_Acc (El_Type1).Layout, + Ctxt)); + if Is_Sig then + El_Size := Sizes.Signal; + else + El_Size := Sizes.Value; + end if; + end; when others => Internal_Error ("add_index"); end case; @@ -1003,6 +1011,7 @@ package body Grt.Avhpi is To_Ghdl_Rtin_Type_Array_Acc (Arr_Subtype.Basetype); Idx : constant Ghdl_Index_Type := Ghdl_Index_Type (Index); + Layout : Address; Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1); Range_Basetype : Ghdl_Rti_Access; begin @@ -1012,10 +1021,10 @@ package body Grt.Avhpi is return; end if; -- constraint type is basetype.indexes (idx - 1) + Layout := Loc_To_Addr (Arr_Subtype.Common.Depth, + Arr_Subtype.Layout, Ref.Ctxt); Bound_To_Range - (Loc_To_Addr (Arr_Subtype.Common.Depth, - Arr_Subtype.Bounds, Ref.Ctxt), - Basetype, Bounds); + (Array_Layout_To_Bounds (Layout), Basetype, Bounds); Res := (Kind => VhpiIntRangeK, Ctxt => Ref.Ctxt, Rng_Type => Basetype.Indexes (Idx - 1), diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb index 7440480da..81e7e2b4c 100644 --- a/src/grt/grt-disp_rti.adb +++ b/src/grt/grt-disp_rti.adb @@ -245,11 +245,12 @@ package body Grt.Disp_Rti is Rti : Ghdl_Rtin_Type_Record_Acc; Ctxt : Rti_Context; Obj : Address; - Bounds : in out Address; + Obj_Layout : Address; Is_Sig : Boolean) is El : Ghdl_Rtin_Element_Acc; El_Addr : Address; + El_Bounds : Address; begin Put (Stream, "("); for I in 1 .. Rti.Nbrel loop @@ -259,8 +260,9 @@ package body Grt.Disp_Rti is end if; Put (Stream, El.Name); Put (" => "); - Record_To_Element_Base (Obj, El, Is_Sig, El_Addr); - Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Bounds, Is_Sig); + Record_To_Element + (Obj, El, Is_Sig, Obj_Layout, El_Addr, El_Bounds); + Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, El_Bounds, Is_Sig); end loop; Put (")"); -- FIXME: update ADDR. @@ -294,9 +296,11 @@ package body Grt.Disp_Rti is To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); Bt : constant Ghdl_Rtin_Type_Array_Acc := To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); + Layout : Address; Bounds : Address; begin - Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt); + Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt); + Bounds := Array_Layout_To_Bounds (Layout); Disp_Array_Value_1 (Stream, Bt, Ctxt, 0, Obj, Bounds, Is_Sig); end; when Ghdl_Rtik_Type_File => @@ -309,8 +313,20 @@ package body Grt.Disp_Rti is -- FIXME: update OBJ (not very useful since never in a -- composite type). end; - when Ghdl_Rtik_Type_Record - | Ghdl_Rtik_Type_Unbounded_Record => + when Ghdl_Rtik_Type_Record => + declare + Bt : constant Ghdl_Rtin_Type_Record_Acc := + To_Ghdl_Rtin_Type_Record_Acc (Rti); + Rec_Layout : Address; + begin + if Rti_Complex_Type (Rti) then + Rec_Layout := Loc_To_Addr (Bt.Common.Depth, Bt.Layout, Ctxt); + else + Rec_Layout := Bounds; + end if; + Disp_Record_Value (Stream, Bt, Ctxt, Obj, Rec_Layout, Is_Sig); + end; + when Ghdl_Rtik_Type_Unbounded_Record => Disp_Record_Value (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Bounds, Is_Sig); @@ -320,10 +336,10 @@ package body Grt.Disp_Rti is To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); Bt : constant Ghdl_Rtin_Type_Record_Acc := To_Ghdl_Rtin_Type_Record_Acc (St.Basetype); - Bounds : Address; + Layout : Address; begin - Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt); - Disp_Record_Value (Stream, Bt, Ctxt, Obj, Bounds, Is_Sig); + Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt); + Disp_Record_Value (Stream, Bt, Ctxt, Obj, Layout, Is_Sig); end; when Ghdl_Rtik_Type_Protected => Put (Stream, "Unhandled protected type"); @@ -536,11 +552,13 @@ package body Grt.Disp_Rti is end Disp_Scalar_Type_Name; procedure Disp_Type_Array_Bounds (Def : Ghdl_Rtin_Type_Array_Acc; - Bounds : in out Address) + Bounds : Address) is Rng : Ghdl_Range_Ptr; Idx_Base : Ghdl_Rti_Access; + Bounds1 : Address; begin + Bounds1 := Bounds; Put (" ("); for I in 0 .. Def.Nbr_Dim - 1 loop if I /= 0 then @@ -551,16 +569,17 @@ package body Grt.Disp_Rti is Put (" range "); end if; Idx_Base := Get_Base_Type (Def.Indexes (I)); - Extract_Range (Bounds, Idx_Base, Rng); + Extract_Range (Bounds1, Idx_Base, Rng); Disp_Range (stdout, Idx_Base, Rng); end loop; Put (")"); end Disp_Type_Array_Bounds; procedure Disp_Type_Record_Bounds (Def : Ghdl_Rtin_Type_Record_Acc; - Bounds : in out Address) + Layout : Address) is El : Ghdl_Rtin_Element_Acc; + El_Layout : Address; First : Boolean; begin Put (" ("); @@ -576,13 +595,15 @@ package body Grt.Disp_Rti is Put (", "); end if; Put (El.Name); + El_Layout := Layout + El.Layout_Off; case El.Eltype.Kind is when Ghdl_Rtik_Type_Array => Disp_Type_Array_Bounds - (To_Ghdl_Rtin_Type_Array_Acc (El.Eltype), Bounds); + (To_Ghdl_Rtin_Type_Array_Acc (El.Eltype), + Array_Layout_To_Bounds (El_Layout)); when Ghdl_Rtik_Type_Unbounded_Record => Disp_Type_Record_Bounds - (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype), Bounds); + (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype), El_Layout); when others => raise Program_Error; end case; @@ -607,16 +628,16 @@ package body Grt.Disp_Rti is end Disp_Type_Array_Name; procedure Disp_Type_Record_Name (Def : Ghdl_Rtin_Type_Record_Acc; - Bounds_Ptr : Address) + Layout_Ptr : Address) is - Bounds : Address; + Layout : Address; begin Disp_Name (Def.Name); - if Bounds_Ptr = Null_Address then + if Layout_Ptr = Null_Address then return; end if; - Bounds := Bounds_Ptr; - Disp_Type_Record_Bounds (Def, Bounds); + Layout := Layout_Ptr; + Disp_Type_Record_Bounds (Def, Layout); end Disp_Type_Record_Name; procedure Disp_Subtype_Scalar_Range @@ -675,7 +696,7 @@ package body Grt.Disp_Rti is else Disp_Type_Record_Name (To_Ghdl_Rtin_Type_Record_Acc (Sdef.Basetype), - Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); + Loc_To_Addr (Sdef.Common.Depth, Sdef.Layout, Ctxt)); end if; end; when Ghdl_Rtik_Type_Array => @@ -694,13 +715,15 @@ package body Grt.Disp_Rti is declare Sdef : constant Ghdl_Rtin_Subtype_Composite_Acc := To_Ghdl_Rtin_Subtype_Composite_Acc (Def); + Layout : Address; begin if Sdef.Name /= null then Disp_Name (Sdef.Name); else + Layout := Loc_To_Addr (Sdef.Common.Depth, Sdef.Layout, Ctxt); Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Sdef.Basetype), - Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); + Array_Layout_To_Bounds (Layout)); end if; end; when Ghdl_Rtik_Type_Protected => @@ -1102,14 +1125,15 @@ package body Grt.Disp_Rti is is Basetype : constant Ghdl_Rtin_Type_Array_Acc := To_Ghdl_Rtin_Type_Array_Acc (Def.Basetype); + Layout : Address; begin Disp_Indent (Indent); Disp_Kind (Def.Common.Kind); Put (": "); Disp_Name (Def.Name); Put (" is "); - Disp_Type_Array_Name - (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt)); + Layout := Loc_To_Addr (Def.Common.Depth, Def.Layout, Ctxt); + Disp_Type_Array_Name (Basetype, Array_Layout_To_Bounds (Layout)); if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then Put (" of "); Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address); @@ -1169,7 +1193,7 @@ package body Grt.Disp_Rti is is Basetype : constant Ghdl_Rtin_Type_Record_Acc := To_Ghdl_Rtin_Type_Record_Acc (Def.Basetype); - Bounds : Address; + Layout : Address; begin Disp_Indent (Indent); Disp_Kind (Def.Common.Kind); @@ -1178,8 +1202,8 @@ package body Grt.Disp_Rti is Put (" is "); Disp_Name (Basetype.Name); if Def.Common.Kind = Ghdl_Rtik_Subtype_Record then - Bounds := Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt); - Disp_Type_Record_Bounds (Basetype, Bounds); + Layout := Loc_To_Addr (Def.Common.Depth, Def.Layout, Ctxt); + Disp_Type_Record_Bounds (Basetype, Layout); end if; New_Line; end Disp_Subtype_Record_Decl; diff --git a/src/grt/grt-rtis.ads b/src/grt/grt-rtis.ads index afe9676c6..030cd7e04 100644 --- a/src/grt/grt-rtis.ads +++ b/src/grt/grt-rtis.ads @@ -120,6 +120,8 @@ package Grt.Rtis is -- bit 0: set for complex type -- bit 1: set for anonymous type definition -- bit 2: set only for physical type with non-static units (time) + -- * record elements: + -- bit 0: set for complex type (copy of the type complex bit). -- * signals: -- bit 0-3: mode (1: linkage, 2: buffer, 3 : out, 4 : inout, 5: in) -- bit 4-5: kind (0 : none, 1 : register, 2 : bus) @@ -311,9 +313,7 @@ package Grt.Rtis is Common : Ghdl_Rti_Common; Name : Ghdl_C_String; Basetype : Ghdl_Rti_Access; - Bounds : Ghdl_Rti_Loc; - Valsize : Ghdl_Rti_Loc; - Sigsize : Ghdl_Rti_Loc; + Layout : Ghdl_Rti_Loc; end record; pragma Convention (C, Ghdl_Rtin_Subtype_Composite); type Ghdl_Rtin_Subtype_Composite_Acc is access Ghdl_Rtin_Subtype_Composite; @@ -332,12 +332,22 @@ package Grt.Rtis is function To_Ghdl_Rtin_Type_Fileacc_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Fileacc_Acc); + -- Set in the mode field to know what Val_Off and Sig_Off are relative to. + -- This could also be extrated from the element type. + Ghdl_Rti_Element_Static : constant Ghdl_Rti_U8 := 0; + Ghdl_Rti_Element_Complex : constant Ghdl_Rti_U8 := 1; + Ghdl_Rti_Element_Unbounded : constant Ghdl_Rti_U8 := 2; + type Ghdl_Rtin_Element is record Common : Ghdl_Rti_Common; Name : Ghdl_C_String; Eltype : Ghdl_Rti_Access; + -- For static element: offset in the record. + -- For complex element: offset in the type layout or object layout. Val_Off : Ghdl_Index_Type; Sig_Off : Ghdl_Index_Type; + -- For unbounded records: element layout offset in the layout. + Layout_Off : Ghdl_Index_Type; end record; pragma Convention (C, Ghdl_Rtin_Element); type Ghdl_Rtin_Element_Acc is access Ghdl_Rtin_Element; @@ -349,6 +359,8 @@ package Grt.Rtis is Name : Ghdl_C_String; Nbrel : Ghdl_Index_Type; Elements : Ghdl_Rti_Arr_Acc; + -- Layout variable for the record, if it is complex. + Layout : Ghdl_Rti_Loc; end record; pragma Convention (C, Ghdl_Rtin_Type_Record); type Ghdl_Rtin_Type_Record_Acc is access Ghdl_Rtin_Type_Record; diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb index 7be70eb02..4881a5abd 100644 --- a/src/grt/grt-rtis_addr.adb +++ b/src/grt/grt-rtis_addr.adb @@ -278,6 +278,11 @@ package body Grt.Rtis_Addr is end case; end Extract_Range; + function Array_Layout_To_Bounds (Layout : Address) return Address is + begin + return Layout + Ghdl_Index_Type'(Ghdl_Indexes_Type'Size / 8); + end Array_Layout_To_Bounds; + procedure Bound_To_Range (Bounds_Addr : Address; Def : Ghdl_Rtin_Type_Array_Acc; Res : out Ghdl_Range_Array) diff --git a/src/grt/grt-rtis_addr.ads b/src/grt/grt-rtis_addr.ads index 550576733..db8e15264 100644 --- a/src/grt/grt-rtis_addr.ads +++ b/src/grt/grt-rtis_addr.ads @@ -51,10 +51,6 @@ package Grt.Rtis_Addr is function To_Addr_Acc is new Ada.Unchecked_Conversion (Source => Address, Target => Addr_Acc); - type Ghdl_Index_Acc is access Ghdl_Index_Type; - function To_Ghdl_Index_Acc is new Ada.Unchecked_Conversion - (Source => Address, Target => Ghdl_Index_Acc); - -- Get the parent context of CTXT. -- The parent of an architecture is its entity. function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context; @@ -91,6 +87,8 @@ package Grt.Rtis_Addr is Def : Ghdl_Rti_Access; Rng : out Ghdl_Range_Ptr); + function Array_Layout_To_Bounds (Layout : Address) return Address; + -- Extract range of every dimension from bounds. procedure Bound_To_Range (Bounds_Addr : Address; Def : Ghdl_Rtin_Type_Array_Acc; diff --git a/src/grt/grt-rtis_utils.adb b/src/grt/grt-rtis_utils.adb index 695de7315..ed4429744 100644 --- a/src/grt/grt-rtis_utils.adb +++ b/src/grt/grt-rtis_utils.adb @@ -22,7 +22,7 @@ -- covered by the GNU General Public License. This exception does not -- however invalidate any other reasons why the executable file might be -- covered by the GNU Public License. ---with Grt.Disp; use Grt.Disp; + with Grt.Errors; use Grt.Errors; package body Grt.Rtis_Utils is @@ -178,32 +178,41 @@ package body Grt.Rtis_Utils is end case; end Object_To_Base_Bounds; - procedure Record_To_Element_Base (Obj : Address; - El : Ghdl_Rtin_Element_Acc; - Is_Sig : Boolean; - Addr : out Address) is + procedure Record_To_Element (Obj : Address; + El : Ghdl_Rtin_Element_Acc; + Is_Sig : Boolean; + Rec_Layout : Address; + El_Addr : out Address; + El_Bounds : out Address) + is + Off : Ghdl_Index_Type; + Off_Addr : Address; begin if Is_Sig then - Addr := Obj + El.Sig_Off; + Off := El.Sig_Off; else - Addr := Obj + El.Val_Off; + Off := El.Val_Off; end if; - case El.Eltype.Kind is - when Ghdl_Rtik_Subtype_Array - | Ghdl_Rtik_Type_Record => - -- Element is an offset. - if Rti_Complex_Type (El.Eltype) then - Addr := Obj + To_Ghdl_Index_Acc (Addr).all; + + case El.Common.Mode is + when Ghdl_Rti_Element_Static => + El_Addr := Obj + Off; + El_Bounds := Null_Address; + when Ghdl_Rti_Element_Complex => + Off_Addr := Rec_Layout + Off; + El_Addr := Obj + To_Ghdl_Index_Ptr (Off_Addr).all; + El_Bounds := Null_Address; + when Ghdl_Rti_Element_Unbounded => + Off_Addr := Rec_Layout + Off; + El_Addr := Obj + To_Ghdl_Index_Ptr (Off_Addr).all; + El_Bounds := Rec_Layout + El.Layout_Off; + if El.Eltype.Kind = Ghdl_Rtik_Type_Array then + El_Bounds := Array_Layout_To_Bounds (El_Bounds); end if; - when Ghdl_Rtik_Type_Array - | Ghdl_Rtik_Type_Unbounded_Record - | Ghdl_Rtik_Subtype_Unbounded_Record => - -- Element is an offset. - Addr := Obj + To_Ghdl_Index_Acc (Addr).all; when others => - null; + Internal_Error ("record_to_element"); end case; - end Record_To_Element_Base; + end Record_To_Element; procedure Foreach_Scalar (Ctxt : Rti_Context; Obj_Type : Ghdl_Rti_Access; @@ -360,26 +369,31 @@ package body Grt.Rtis_Utils is procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc) is + Rec_Addr : constant Address := Addr; + Rec_Bounds : constant Address := Bounds; + Sizes : constant Ghdl_Indexes_Ptr := + To_Ghdl_Indexes_Ptr (Bounds); El : Ghdl_Rtin_Element_Acc; - Obj_Addr : Address; - Last_Addr : Address; + El_Addr : Address; P : Natural; begin P := Length (Name); - Obj_Addr := Addr; - Last_Addr := Addr; for I in 1 .. Rti.Nbrel loop El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); - Record_To_Element_Base (Obj_Addr, El, Is_Sig, Addr); + Record_To_Element + (Rec_Addr, El, Is_Sig, Rec_Bounds, El_Addr, Bounds); Append (Name, '.'); Append (Name, El.Name); Handle_Any (El.Eltype); - if Addr > Last_Addr then - Last_Addr := Addr; - end if; Truncate (Name, P); end loop; - Addr := Last_Addr; + if Is_Sig then + Addr := Rec_Addr + Sizes.Signal; + else + Addr := Rec_Addr + Sizes.Value; + end if; + -- Bounds was fully used, no need to restore it. + Bounds := Null_Address; end Handle_Record; procedure Handle_Any (Rti : Ghdl_Rti_Access) is @@ -401,8 +415,10 @@ package body Grt.Rtis_Utils is Bt : constant Ghdl_Rtin_Type_Array_Acc := To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); Prev_Bounds : constant Address := Bounds; + Layout : Address; begin - Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt); + Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt); + Bounds := Array_Layout_To_Bounds (Layout); Handle_Array_1 (Bt, 0); Bounds := Prev_Bounds; end; @@ -416,8 +432,18 @@ package body Grt.Rtis_Utils is -- -- FIXME: update OBJ (not very useful since never in a -- -- composite type). -- end; - when Ghdl_Rtik_Type_Record - | Ghdl_Rtik_Type_Unbounded_Record => + when Ghdl_Rtik_Type_Record => + declare + Bt : constant Ghdl_Rtin_Type_Record_Acc := + To_Ghdl_Rtin_Type_Record_Acc (Rti); + Prev_Bounds : constant Address := Bounds; + begin + Bounds := Loc_To_Addr (Bt.Common.Depth, Bt.Layout, Ctxt); + Handle_Record (Bt); + Bounds := Prev_Bounds; + end; + when Ghdl_Rtik_Type_Unbounded_Record => + -- Bounds (layout) must have been extracted. Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti)); when Ghdl_Rtik_Subtype_Record => declare @@ -427,7 +453,7 @@ package body Grt.Rtis_Utils is To_Ghdl_Rtin_Type_Record_Acc (St.Basetype); Prev_Bounds : constant Address := Bounds; begin - Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt); + Bounds := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt); Handle_Record (Bt); Bounds := Prev_Bounds; end; diff --git a/src/grt/grt-rtis_utils.ads b/src/grt/grt-rtis_utils.ads index 71d9e963b..537f1bff8 100644 --- a/src/grt/grt-rtis_utils.ads +++ b/src/grt/grt-rtis_utils.ads @@ -70,10 +70,12 @@ package Grt.Rtis_Utils is Bounds : out Address); -- Get address of element EL for record at OBJ. - procedure Record_To_Element_Base (Obj : Address; - El : Ghdl_Rtin_Element_Acc; - Is_Sig : Boolean; - Addr : out Address); + procedure Record_To_Element (Obj : Address; + El : Ghdl_Rtin_Element_Acc; + Is_Sig : Boolean; + Rec_Layout : Address; + El_Addr : out Address; + El_Bounds : out Address); procedure Get_Value (Str : in out Vstring; Value : Value_Union; diff --git a/src/grt/grt-types.ads b/src/grt/grt-types.ads index d9b17f67e..f75711eeb 100644 --- a/src/grt/grt-types.ads +++ b/src/grt/grt-types.ads @@ -285,6 +285,16 @@ package Grt.Types is type Ghdl_Range_Array is array (Ghdl_Index_Type range <>) of Ghdl_Range_Ptr; + type Ghdl_Indexes_Type is record + Value : Ghdl_Index_Type; + Signal : Ghdl_Index_Type; + end record; + + type Ghdl_Indexes_Ptr is access all Ghdl_Indexes_Type; + + function To_Ghdl_Indexes_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Indexes_Ptr); + -- For PSL counters. type Ghdl_Index_Ptr is access all Ghdl_Index_Type; diff --git a/src/grt/grt-vcd.adb b/src/grt/grt-vcd.adb index 180bfeeb9..9050a26a4 100644 --- a/src/grt/grt-vcd.adb +++ b/src/grt/grt-vcd.adb @@ -360,8 +360,9 @@ package body Grt.Vcd is Get_Base_Type (Arr_Rti.Indexes (0)); begin Kind := Rti_To_Vcd_Kind (Arr_Rti); - Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, + Bounds := Loc_To_Addr (St.Common.Depth, St.Layout, Avhpi_Get_Context (Sig)); + Bounds := Array_Layout_To_Bounds (Bounds); Extract_Range (Bounds, Idx_Rti, Irange); end; when Ghdl_Rtik_Type_Array => diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb index 74d764e67..ffe174bf6 100644 --- a/src/grt/grt-waves.adb +++ b/src/grt/grt-waves.adb @@ -1276,14 +1276,16 @@ package body Grt.Waves is end Write_Range; procedure Write_Array_Bounds (Arr : Ghdl_Rtin_Type_Array_Acc; - Bounds : in out Address) + Bounds : Address) is Rng : Ghdl_Range_Ptr; Index_Type : Ghdl_Rti_Access; + Bounds1 : Address; begin + Bounds1 := Bounds; for I in 0 .. Arr.Nbr_Dim - 1 loop Index_Type := Get_Base_Type (Arr.Indexes (I)); - Extract_Range (Bounds, Index_Type, Rng); + Extract_Range (Bounds1, Index_Type, Rng); Write_Range (Index_Type, Rng); end loop; end Write_Array_Bounds; @@ -1393,10 +1395,11 @@ package body Grt.Waves is declare Bt : constant Ghdl_Rtin_Type_Array_Acc := To_Ghdl_Rtin_Type_Array_Acc (Arr.Basetype); - Bounds : Address; + Layout : Address; begin - Bounds := Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt); - Write_Array_Bounds (Bt, Bounds); + Layout := Loc_To_Addr (Rti.Depth, Arr.Layout, Ctxt); + Write_Array_Bounds + (Bt, Array_Layout_To_Bounds (Layout)); end; end; when Ghdl_Rtik_Type_Array => @@ -1432,14 +1435,14 @@ package body Grt.Waves is To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); Base : constant Ghdl_Rtin_Type_Record_Acc := To_Ghdl_Rtin_Type_Record_Acc (Rec.Basetype); - Bounds : Address; + Layout : Address; begin Write_String_Id (Rec.Name); Write_Type_Id (Rec.Basetype, Ctxt); if Base.Common.Kind = Ghdl_Rtik_Type_Unbounded_Record then - Bounds := Loc_To_Addr - (Rec.Common.Depth, Rec.Bounds, Ctxt); - Write_Record_Bounds (Base, Bounds); + Layout := Loc_To_Addr + (Rec.Common.Depth, Rec.Layout, Ctxt); + Write_Record_Bounds (Base, Layout); end if; end; when Ghdl_Rtik_Subtype_Scalar => diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb index 53e4a6767..51707786e 100644 --- a/src/ortho/debug/ortho_debug-disp.adb +++ b/src/ortho/debug/ortho_debug-disp.adb @@ -264,6 +264,7 @@ package body Ortho_Debug.Disp is procedure Disp_Enode (E : O_Enode; Etype : O_Tnode); procedure Disp_Lnode (Node : O_Lnode); + procedure Disp_Gnode (Node : O_Gnode); procedure Disp_Snode (First, Last : O_Snode); procedure Disp_Dnode (Decl : O_Dnode); procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean); @@ -556,17 +557,17 @@ package body Ortho_Debug.Disp is when OC_Address => Disp_Tnode_Name (C.Ctype); Put ("'address ("); - Disp_Dnode_Name (C.Decl); + Disp_Gnode (C.Addr_Global); Put (")"); when OC_Unchecked_Address => Disp_Tnode_Name (C.Ctype); Put ("'unchecked_address ("); - Disp_Dnode_Name (C.Decl); + Disp_Gnode (C.Addr_Global); Put (")"); when OC_Subprogram_Address => Disp_Tnode_Name (C.Ctype); Put ("'subprg_addr ("); - Disp_Dnode_Name (C.Decl); + Disp_Dnode_Name (C.Addr_Decl); Put (")"); end case; end Disp_Cnode; @@ -677,13 +678,21 @@ package body Ortho_Debug.Disp is Disp_Lnode (Node.Rec_Base); Put ('.'); Disp_Ident (Node.Rec_El.Ident); --- when OL_Var_Ref --- | OL_Const_Ref --- | OL_Param_Ref => --- Disp_Dnode_Name (Node.Decl); end case; end Disp_Lnode; + procedure Disp_Gnode (Node : O_Gnode) is + begin + case Node.Kind is + when OG_Decl => + Disp_Dnode_Name (Node.Decl); + when OG_Selected_Element => + Disp_Gnode (Node.Rec_Base); + Put ('.'); + Disp_Ident (Node.Rec_El.Ident); + end case; + end Disp_Gnode; + procedure Disp_Fnodes (First : O_Fnode) is El : O_Fnode; diff --git a/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb index 3645b89e8..bb32197a4 100644 --- a/src/ortho/debug/ortho_debug.adb +++ b/src/ortho/debug/ortho_debug.adb @@ -288,6 +288,14 @@ package body Ortho_Debug is N.Ref := True; end Check_Ref; + procedure Check_Ref (N : O_Gnode) is + begin + if N.Ref then + raise Syntax_Error; + end if; + N.Ref := True; + end Check_Ref; + procedure Check_Complete_Type (T : O_Tnode) is begin if not T.Complete then @@ -928,7 +936,7 @@ package body Ortho_Debug is | ON_Interface_Decl => null; when others => - raise Program_Error; + raise Syntax_Error; end case; Check_Scope (Obj); return new O_Lnode_Obj'(Kind => OL_Obj, @@ -937,8 +945,28 @@ package body Ortho_Debug is Obj => Obj); end New_Obj; + function New_Global (Decl : O_Dnode) return O_Gnode + is + subtype O_Gnode_Decl is O_Gnode_Type (OG_Decl); + begin + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + null; + when others => + raise Syntax_Error; + end case; + if Decl.Storage = O_Storage_Local then + raise Syntax_Error; + end if; + return new O_Gnode_Decl'(Kind => OG_Decl, + Rtype => Decl.Dtype, + Ref => False, + Decl => Decl); + end New_Global; + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode + return O_Lnode is subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element); Res : O_Lnode; @@ -953,7 +981,7 @@ package body Ortho_Debug is end New_Indexed_Element; function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode + return O_Lnode is subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice); Res : O_Lnode; @@ -995,6 +1023,27 @@ package body Ortho_Debug is Rec_El => El); end New_Selected_Element; + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + subtype O_Gnode_Selected_Element is O_Gnode_Type (OG_Selected_Element); + begin + if Rec.Rtype.Kind /= ON_Record_Type + and then Rec.Rtype.Kind /= ON_Union_Type + then + raise Type_Error; + end if; + if Rec.Rtype /= El.Parent then + raise Type_Error; + end if; + Check_Ref (Rec); + return new O_Gnode_Selected_Element'(Kind => OG_Selected_Element, + Rtype => El.Ftype, + Ref => False, + Rec_Base => Rec, + Rec_El => El); + end New_Global_Selected_Element; + function New_Access_Element (Acc : O_Enode) return O_Lnode is subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element); @@ -1086,12 +1135,13 @@ package body Ortho_Debug is Lvalue => Lvalue); end New_Address; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address); begin - Check_Scope (Decl); + -- FIXME: check Lvalue is a static object. + Check_Ref (Lvalue); if Atype.Kind /= ON_Access_Type then -- An address is of type access. raise Type_Error; @@ -1099,25 +1149,27 @@ package body Ortho_Debug is return new O_Cnode_Address'(Kind => OC_Unchecked_Address, Ctype => Atype, Ref => False, - Decl => Decl); + Addr_Global => Lvalue); end New_Global_Unchecked_Address; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is subtype O_Cnode_Address is O_Cnode_Type (OC_Address); begin - Check_Scope (Decl); + -- FIXME: check Lvalue is a static object. + Check_Ref (Lvalue); if Atype.Kind /= ON_Access_Type then -- An address is of type access. raise Type_Error; end if; - if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then + if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then raise Type_Error; end if; return new O_Cnode_Address'(Kind => OC_Address, Ctype => Atype, Ref => False, - Decl => Decl); + Addr_Global => Lvalue); end New_Global_Address; function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) @@ -1132,7 +1184,7 @@ package body Ortho_Debug is return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address, Ctype => Atype, Ref => False, - Decl => Subprg); + Addr_Decl => Subprg); end New_Subprogram_Address; -- Raise TYPE_ERROR is ATYPE is a composite type. diff --git a/src/ortho/debug/ortho_debug.private.ads b/src/ortho/debug/ortho_debug.private.ads index a1e711b62..b505ff434 100644 --- a/src/ortho/debug/ortho_debug.private.ads +++ b/src/ortho/debug/ortho_debug.private.ads @@ -179,9 +179,10 @@ private Aggr_Value : O_Cnode; Aggr_Next : O_Cnode; when OC_Address - | OC_Unchecked_Address - | OC_Subprogram_Address => - Decl : O_Dnode; + | OC_Unchecked_Address => + Addr_Global : O_Gnode; + when OC_Subprogram_Address => + Addr_Decl : O_Dnode; end case; end record; @@ -280,12 +281,6 @@ private OL_Slice, OL_Selected_Element, OL_Access_Element - - -- Variable, constant, parameter reference. - -- This allows to read/write a declaration. - --OL_Var_Ref, - --OL_Const_Ref, - --OL_Param_Ref ); type O_Lnode_Type (Kind : OL_Kind); @@ -311,10 +306,30 @@ private Rec_El : O_Fnode; when OL_Access_Element => Acc_Base : O_Enode; --- when OL_Var_Ref --- | OL_Const_Ref --- | OL_Param_Ref => --- Decl : O_Dnode; + end case; + end record; + + type OG_Kind is + ( + OG_Decl, + OG_Selected_Element + ); + + type O_Gnode_Type (Kind : OG_Kind); + type O_Gnode is access O_Gnode_Type; + O_Gnode_Null : constant O_Gnode := null; + + type O_Gnode_Type (Kind : OG_Kind) is record + -- Type of the result. + Rtype : O_Tnode; + -- True if referenced. + Ref : Boolean; + case Kind is + when OG_Decl => + Decl : O_Dnode; + when OG_Selected_Element => + Rec_Base : O_Gnode; + Rec_El : O_Fnode; end case; end record; diff --git a/src/ortho/gcc/ortho_gcc.adb b/src/ortho/gcc/ortho_gcc.adb index ae7b4f53b..37f782dcd 100644 --- a/src/ortho/gcc/ortho_gcc.adb +++ b/src/ortho/gcc/ortho_gcc.adb @@ -30,6 +30,17 @@ package body Ortho_Gcc is return O_Lnode (Obj); end New_Obj; + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + return O_Gnode (Decl); + end New_Global; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode is + begin + return O_Gnode (New_Selected_Element (O_Lnode (Rec), El)); + end New_Global_Selected_Element; + function New_Obj_Value (Obj : O_Dnode) return O_Enode is begin return O_Enode (Obj); diff --git a/src/ortho/gcc/ortho_gcc.ads b/src/ortho/gcc/ortho_gcc.ads index 7332ceb21..6273435dc 100644 --- a/src/ortho/gcc/ortho_gcc.ads +++ b/src/ortho/gcc/ortho_gcc.ads @@ -34,10 +34,12 @@ package Ortho_Gcc is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -183,17 +185,17 @@ package Ortho_Gcc is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -292,12 +294,15 @@ package Ortho_Gcc is -- base type of ARR. -- INDEX must be of the type of the array index. function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -324,6 +329,9 @@ package Ortho_Gcc is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; @@ -474,6 +482,7 @@ private type O_Cnode is new Tree; type O_Enode is new Tree; type O_Lnode is new Tree; + type O_Gnode is new Tree; type O_Tnode is new Tree; type O_Fnode is new Tree; type O_Dnode is new Tree; @@ -486,6 +495,7 @@ private O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); + O_Gnode_Null : constant O_Gnode := O_Gnode (NULL_TREE); O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE); diff --git a/src/ortho/gcc/ortho_gcc.private.ads b/src/ortho/gcc/ortho_gcc.private.ads index fcbc59129..3bae8526e 100644 --- a/src/ortho/gcc/ortho_gcc.private.ads +++ b/src/ortho/gcc/ortho_gcc.private.ads @@ -38,6 +38,7 @@ private type O_Cnode is new Tree; type O_Enode is new Tree; type O_Lnode is new Tree; + type O_Gnode is new Tree; type O_Tnode is new Tree; type O_Fnode is new Tree; type O_Dnode is new Tree; @@ -50,6 +51,7 @@ private O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE); O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE); O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE); + O_Gnode_Null : constant O_Gnode := O_Gnode (NULL_TREE); O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE); O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE); O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE); diff --git a/src/ortho/llvm-nodebug/ortho_llvm.adb b/src/ortho/llvm-nodebug/ortho_llvm.adb index 7eb7277c6..443b469aa 100644 --- a/src/ortho/llvm-nodebug/ortho_llvm.adb +++ b/src/ortho/llvm-nodebug/ortho_llvm.adb @@ -779,22 +779,21 @@ package body Ortho_LLVM is -- New_Global_Address -- ------------------------ - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); + return New_Global_Unchecked_Address (Lvalue, Atype); end New_Global_Address; ---------------------------------- -- New_Global_Unchecked_Address -- ---------------------------------- - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), + return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM, + Get_LLVM_Type (Atype)), Ctype => Atype); end New_Global_Unchecked_Address; @@ -808,6 +807,24 @@ package body Ortho_LLVM is Etype => Lit.Ctype); end New_Lit; + ---------------- + -- New_Global -- + ---------------- + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + return O_Gnode'(LLVM => Decl.LLVM, + Ltype => Decl.Dtype); + when others => + raise Program_Error; + end case; + end New_Global; + ------------------- -- New_Dyadic_Op -- ------------------- @@ -1174,6 +1191,28 @@ package body Ortho_LLVM is return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); end New_Selected_Element; + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : ValueRef; + begin + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := ConstGEP (Rec.LLVM, Idx, 2); + end; + when OF_Union => + Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); + when OF_None => + raise Program_Error; + end case; + return O_Gnode'(LLVM => Res, Ltype => El.Ftype); + end New_Global_Selected_Element; + ------------------------ -- New_Access_Element -- ------------------------ @@ -1364,12 +1403,8 @@ package body Ortho_LLVM is function New_Obj (Obj : O_Dnode) return O_Lnode is begin - if Unreach then - return O_Lnode'(Direct => False, - LLVM => Null_ValueRef, - Ltype => Obj.Dtype); - end if; - + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. case Obj.Kind is when ON_Const_Decl | ON_Var_Decl @@ -1718,7 +1753,8 @@ package body Ortho_LLVM is Cur_Func := Func.LLVM; Cur_Func_Decl := Func; - Unreach := False; + + pragma Assert (not Unreach); Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); PositionBuilderAtEnd (Decl_Builder, Decl_BB); @@ -1751,6 +1787,8 @@ package body Ortho_LLVM is Destroy_Declare_Block; Cur_Func := Null_ValueRef; + + Unreach := False; end Finish_Subprogram_Body; ------------------------- diff --git a/src/ortho/llvm-nodebug/ortho_llvm.private.ads b/src/ortho/llvm-nodebug/ortho_llvm.private.ads index e5527a734..723aa5c7a 100644 --- a/src/ortho/llvm-nodebug/ortho_llvm.private.ads +++ b/src/ortho/llvm-nodebug/ortho_llvm.private.ads @@ -178,6 +178,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/llvm/ortho_llvm.adb b/src/ortho/llvm/ortho_llvm.adb index d5e172532..250870224 100644 --- a/src/ortho/llvm/ortho_llvm.adb +++ b/src/ortho/llvm/ortho_llvm.adb @@ -1115,22 +1115,21 @@ package body Ortho_LLVM is -- New_Global_Address -- ------------------------ - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); + return New_Global_Unchecked_Address (Lvalue, Atype); end New_Global_Address; ---------------------------------- -- New_Global_Unchecked_Address -- ---------------------------------- - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), + return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM, + Get_LLVM_Type (Atype)), Ctype => Atype); end New_Global_Unchecked_Address; @@ -1144,6 +1143,24 @@ package body Ortho_LLVM is Etype => Lit.Ctype); end New_Lit; + ---------------- + -- New_Global -- + ---------------- + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + return O_Gnode'(LLVM => Decl.LLVM, + Ltype => Decl.Dtype); + when others => + raise Program_Error; + end case; + end New_Global; + ------------------- -- New_Dyadic_Op -- ------------------- @@ -1517,6 +1534,28 @@ package body Ortho_LLVM is return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); end New_Selected_Element; + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : ValueRef; + begin + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := ConstGEP (Rec.LLVM, Idx, 2); + end; + when OF_Union => + Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); + when OF_None => + raise Program_Error; + end case; + return O_Gnode'(LLVM => Res, Ltype => El.Ftype); + end New_Global_Selected_Element; + ------------------------ -- New_Access_Element -- ------------------------ @@ -1708,12 +1747,8 @@ package body Ortho_LLVM is function New_Obj (Obj : O_Dnode) return O_Lnode is begin - if Unreach then - return O_Lnode'(Direct => False, - LLVM => Null_ValueRef, - Ltype => Obj.Dtype); - end if; - + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. case Obj.Kind is when ON_Const_Decl | ON_Var_Decl @@ -2257,7 +2292,8 @@ package body Ortho_LLVM is Cur_Func := Func.LLVM; Cur_Func_Decl := Func; - Unreach := False; + + pragma Assert (not Unreach); Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); PositionBuilderAtEnd (Decl_Builder, Decl_BB); @@ -2399,6 +2435,9 @@ package body Ortho_LLVM is Destroy_Declare_Block; Cur_Func := Null_ValueRef; + + Unreach := False; + Dbg_Current_Scope := Null_ValueRef; Dbg_Insn_MD := Null_ValueRef; end Finish_Subprogram_Body; diff --git a/src/ortho/llvm/ortho_llvm.ads b/src/ortho/llvm/ortho_llvm.ads index 1dca66f4e..2779d0233 100644 --- a/src/ortho/llvm/ortho_llvm.ads +++ b/src/ortho/llvm/ortho_llvm.ads @@ -57,10 +57,12 @@ package Ortho_LLVM is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -206,17 +208,17 @@ package Ortho_LLVM is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -315,12 +317,15 @@ package Ortho_LLVM is -- base type of ARR. -- INDEX must be of the type of the array index. function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -347,6 +352,9 @@ package Ortho_LLVM is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; @@ -621,6 +629,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/llvm/ortho_llvm.private.ads b/src/ortho/llvm/ortho_llvm.private.ads index a4041cb44..ce0685a90 100644 --- a/src/ortho/llvm/ortho_llvm.private.ads +++ b/src/ortho/llvm/ortho_llvm.private.ads @@ -185,6 +185,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.adb b/src/ortho/llvm4-nodebug/ortho_llvm.adb index 4e02a908a..2f0edca3c 100644 --- a/src/ortho/llvm4-nodebug/ortho_llvm.adb +++ b/src/ortho/llvm4-nodebug/ortho_llvm.adb @@ -782,22 +782,21 @@ package body Ortho_LLVM is -- New_Global_Address -- ------------------------ - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), - Ctype => Atype); + return New_Global_Unchecked_Address (Lvalue, Atype); end New_Global_Address; ---------------------------------- -- New_Global_Unchecked_Address -- ---------------------------------- - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is begin - return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)), + return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM, + Get_LLVM_Type (Atype)), Ctype => Atype); end New_Global_Unchecked_Address; @@ -811,6 +810,24 @@ package body Ortho_LLVM is Etype => Lit.Ctype); end New_Lit; + ---------------- + -- New_Global -- + ---------------- + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. + case Decl.Kind is + when ON_Const_Decl + | ON_Var_Decl => + return O_Gnode'(LLVM => Decl.LLVM, + Ltype => Decl.Dtype); + when others => + raise Program_Error; + end case; + end New_Global; + ------------------- -- New_Dyadic_Op -- ------------------- @@ -1177,6 +1194,28 @@ package body Ortho_LLVM is return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype); end New_Selected_Element; + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : ValueRef; + begin + case El.Kind is + when OF_Record => + declare + Idx : constant ValueRefArray (1 .. 2) := + (ConstInt (Int32Type, 0, 0), + ConstInt (Int32Type, Unsigned_64 (El.Index), 0)); + begin + Res := ConstGEP (Rec.LLVM, Idx, 2); + end; + when OF_Union => + Res := ConstBitCast (Rec.LLVM, El.Ptr_Type); + when OF_None => + raise Program_Error; + end case; + return O_Gnode'(LLVM => Res, Ltype => El.Ftype); + end New_Global_Selected_Element; + ------------------------ -- New_Access_Element -- ------------------------ @@ -1367,12 +1406,8 @@ package body Ortho_LLVM is function New_Obj (Obj : O_Dnode) return O_Lnode is begin - if Unreach then - return O_Lnode'(Direct => False, - LLVM => Null_ValueRef, - Ltype => Obj.Dtype); - end if; - + -- Can be used to build global objects, even when Unreach is set. + -- As this doesn't generate code, this is ok. case Obj.Kind is when ON_Const_Decl | ON_Var_Decl @@ -1725,7 +1760,8 @@ package body Ortho_LLVM is Cur_Func := Func.LLVM; Cur_Func_Decl := Func; - Unreach := False; + + pragma Assert (not Unreach); Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring); PositionBuilderAtEnd (Decl_Builder, Decl_BB); @@ -1758,6 +1794,8 @@ package body Ortho_LLVM is Destroy_Declare_Block; Cur_Func := Null_ValueRef; + + Unreach := False; end Finish_Subprogram_Body; ------------------------- diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.ads b/src/ortho/llvm4-nodebug/ortho_llvm.ads index 772a91894..837f4846e 100644 --- a/src/ortho/llvm4-nodebug/ortho_llvm.ads +++ b/src/ortho/llvm4-nodebug/ortho_llvm.ads @@ -50,10 +50,12 @@ package Ortho_LLVM is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -199,17 +201,17 @@ package Ortho_LLVM is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -308,12 +310,15 @@ package Ortho_LLVM is -- base type of ARR. -- INDEX must be of the type of the array index. function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -340,6 +345,9 @@ package Ortho_LLVM is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; @@ -614,6 +622,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.private.ads b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads index e5527a734..723aa5c7a 100644 --- a/src/ortho/llvm4-nodebug/ortho_llvm.private.ads +++ b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads @@ -178,6 +178,13 @@ private O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null); + type O_Gnode is record + LLVM : ValueRef; + Ltype : O_Tnode; + end record; + + O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null); + type O_Snode is record -- First BB in the loop body. Bb_Entry : BasicBlockRef; diff --git a/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb index 7cc554211..1b2146dc4 100644 --- a/src/ortho/mcode/ortho_code-consts.adb +++ b/src/ortho/mcode/ortho_code-consts.adb @@ -19,6 +19,7 @@ with Ada.Unchecked_Conversion; with Tables; with Ada.Text_IO; with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Decls; with Ortho_Code.Debug; package body Ortho_Code.Consts is @@ -59,6 +60,12 @@ package body Ortho_Code.Consts is end record; for Cnode_Addr'Size use 64; + type Cnode_Global is record + Obj : O_Gnode; + Pad : Int32; + end record; + for Cnode_Global'Size use 64; + type Cnode_Aggr is record Els : Int32; Nbr : Int32; @@ -83,11 +90,43 @@ package body Ortho_Code.Consts is Table_Low_Bound => 2, Table_Initial => 128); + type Gnode_Common is record + Kind : OG_Kind; + Ref : Int32; + end record; + for Gnode_Common use record + Kind at 0 range 0 .. 31; + Ref at 4 range 0 .. 31; + end record; + for Gnode_Common'Size use 64; + + type Gnode_Record_Ref is record + Field : O_Fnode; + Off : Uns32; + end record; + for Gnode_Record_Ref'Size use 64; + + function To_Gnode_Common is new Ada.Unchecked_Conversion + (Gnode_Record_Ref, Gnode_Common); + function To_Gnode_Record_Ref is new Ada.Unchecked_Conversion + (Gnode_Common, Gnode_Record_Ref); + + package Gnodes is new Tables + (Table_Component_Type => Gnode_Common, + Table_Index_Type => O_Gnode, + Table_Low_Bound => 2, + Table_Initial => 64); + function Get_Const_Kind (Cst : O_Cnode) return OC_Kind is begin return Cnodes.Table (Cst).Kind; end Get_Const_Kind; + function Get_Global_Kind (Cst : O_Gnode) return OG_Kind is + begin + return Gnodes.Table (Cst).Kind; + end Get_Global_Kind; + function Get_Const_Type (Cst : O_Cnode) return O_Tnode is begin return Cnodes.Table (Cst).Lit_Type; @@ -227,12 +266,12 @@ package body Ortho_Code.Consts is end New_Default_Value; function To_Cnode_Common is new Ada.Unchecked_Conversion - (Source => Cnode_Addr, Target => Cnode_Common); + (Source => Cnode_Global, Target => Cnode_Common); - function To_Cnode_Addr is new Ada.Unchecked_Conversion - (Source => Cnode_Common, Target => Cnode_Addr); + function To_Cnode_Global is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Global); - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is Res : O_Cnode; @@ -240,12 +279,12 @@ package body Ortho_Code.Consts is Cnodes.Append (Cnode_Common'(Kind => OC_Address, Lit_Type => Atype)); Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, - Pad => 0))); + Cnodes.Append (To_Cnode_Common (Cnode_Global'(Obj => Lvalue, + Pad => 0))); return Res; end New_Global_Unchecked_Address; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is Res : O_Cnode; @@ -253,11 +292,23 @@ package body Ortho_Code.Consts is Cnodes.Append (Cnode_Common'(Kind => OC_Address, Lit_Type => Atype)); Res := Cnodes.Last; - Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, - Pad => 0))); + Cnodes.Append (To_Cnode_Common (Cnode_Global'(Obj => Lvalue, + Pad => 0))); return Res; end New_Global_Address; + function Get_Const_Global (Cst : O_Cnode) return O_Gnode is + begin + pragma Assert (Get_Const_Kind (Cst) = OC_Address); + return To_Cnode_Global (Cnodes.Table (Cst + 1)).Obj; + end Get_Const_Global; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Addr, Target => Cnode_Common); + + function To_Cnode_Addr is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Addr); + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) return O_Cnode is @@ -273,6 +324,7 @@ package body Ortho_Code.Consts is function Get_Const_Decl (Cst : O_Cnode) return O_Dnode is begin + pragma Assert (Get_Const_Kind (Cst) = OC_Subprg_Address); return To_Cnode_Addr (Cnodes.Table (Cst + 1)).Decl; end Get_Const_Decl; @@ -512,6 +564,74 @@ package body Ortho_Code.Consts is (Rtype, Unsigned_64 (Get_Field_Offset (Field))); end New_Offsetof; + function Get_Global_Decl (Global : O_Gnode) return O_Dnode is + begin + pragma Assert (Get_Global_Kind (Global) = OG_Decl); + return O_Dnode (Gnodes.Table (Global).Ref); + end Get_Global_Decl; + + function Get_Global_Field (Global : O_Gnode) return O_Fnode is + begin + pragma Assert (Get_Global_Kind (Global) = OG_Record_Ref); + return To_Gnode_Record_Ref (Gnodes.Table (Global + 1)).Field; + end Get_Global_Field; + + function Get_Global_Ref (Global : O_Gnode) return O_Gnode is + begin + pragma Assert (Get_Global_Kind (Global) = OG_Record_Ref); + return O_Gnode (Gnodes.Table (Global).Ref); + end Get_Global_Ref; + + function Get_Global_Type (Global : O_Gnode) return O_Tnode is + begin + case Get_Global_Kind (Global) is + when OG_Decl => + return Decls.Get_Decl_Type (Get_Global_Decl (Global)); + when OG_Record_Ref => + return Get_Field_Type (Get_Global_Field (Global)); + end case; + end Get_Global_Type; + + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + Gnodes.Append (Gnode_Common'(Kind => OG_Decl, + Ref => Int32 (Decl))); + return Gnodes.Last; + end New_Global; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode + is + Res : O_Gnode; + begin + -- TODO: Check Ref. + + -- Check type. + pragma Assert + (Get_Type_Kind (Get_Global_Type (Rec)) in OT_Kinds_Record_Union); + + Gnodes.Append (Gnode_Common'(Kind => OG_Record_Ref, + Ref => Int32 (Rec))); + Res := Gnodes.Last; + Gnodes.Append (To_Gnode_Common + (Gnode_Record_Ref'(Field => El, + Off => Get_Field_Offset (El)))); + return Res; + end New_Global_Selected_Element; + + procedure Get_Global_Decl_Offset (Global : O_Gnode; + Decl : out O_Dnode; Off : out Uns32) is + begin + case Get_Global_Kind (Global) is + when OG_Decl => + Decl := Get_Global_Decl (Global); + Off := 0; + when OG_Record_Ref => + Get_Global_Decl_Offset (Get_Global_Ref (Global), Decl, Off); + Off := Off + Get_Field_Offset (Get_Global_Field (Global)); + end case; + end Get_Global_Decl_Offset; + procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32) is begin case Get_Const_Kind (Cst) is diff --git a/src/ortho/mcode/ortho_code-consts.ads b/src/ortho/mcode/ortho_code-consts.ads index 0a4f347fc..dcb719f26 100644 --- a/src/ortho/mcode/ortho_code-consts.ads +++ b/src/ortho/mcode/ortho_code-consts.ads @@ -24,6 +24,8 @@ package Ortho_Code.Consts is OC_Subprg_Address, OC_Address, OC_Sizeof, OC_Alignof); + type OG_Kind is (OG_Decl, OG_Record_Ref); + function Get_Const_Kind (Cst : O_Cnode) return OC_Kind; function Get_Const_Type (Cst : O_Cnode) return O_Tnode; @@ -54,9 +56,12 @@ package Ortho_Code.Consts is function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode; function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode; - -- Declaration for an address. + -- Declaration for a subprogram address. function Get_Const_Decl (Cst : O_Cnode) return O_Dnode; + -- Object for a global object address. + function Get_Const_Global (Cst : O_Cnode) return O_Gnode; + -- Get the type from an OC_Sizeof node. function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode; @@ -77,14 +82,22 @@ package Ortho_Code.Consts is -- Create a null access literal. function New_Null_Access (Ltype : O_Tnode) return O_Cnode; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; function New_Default_Value (Ltype : O_Tnode) return O_Cnode; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) return O_Cnode; + function New_Global (Decl : O_Dnode) return O_Gnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; + + procedure Get_Global_Decl_Offset (Global : O_Gnode; + Decl : out O_Dnode; Off : out Uns32); + function New_Named_Literal (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode) return O_Cnode; diff --git a/src/ortho/mcode/ortho_code-decls.ads b/src/ortho/mcode/ortho_code-decls.ads index 70a0ba4df..bd84bf2eb 100644 --- a/src/ortho/mcode/ortho_code-decls.ads +++ b/src/ortho/mcode/ortho_code-decls.ads @@ -19,24 +19,27 @@ with Ortho_Code.Abi; package Ortho_Code.Decls is -- Kind of a declaration. - type OD_Kind is (OD_Type, - OD_Const, + type OD_Kind is + ( + OD_Type, + OD_Const, - -- Value of constant, initial value of variable. - OD_Init_Val, + -- Value of constant, initial value of variable. + OD_Init_Val, - -- Global and local variables. - OD_Var, OD_Local, + -- Global and local variables. + OD_Var, OD_Local, - -- Subprograms. - OD_Function, OD_Procedure, + -- Subprograms. + OD_Function, OD_Procedure, - -- Additional node for a subprogram. Internal use only. - OD_Subprg_Ext, + -- Additional node for a subprogram. Internal use only. + OD_Subprg_Ext, - OD_Interface, - OD_Body, - OD_Block); + OD_Interface, + OD_Body, + OD_Block + ); -- Return the kind of declaration DECL. function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind; @@ -126,11 +129,10 @@ package Ortho_Code.Decls is -- This simply gives a name to a constant value or aggregate. -- A constant cannot be modified and its storage cannot be local. -- ATYPE must be constrained. - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); + procedure New_Const_Decl (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); -- Set the value to DECL. procedure New_Init_Value (Decl : O_Dnode; Val : O_Cnode); @@ -138,11 +140,10 @@ package Ortho_Code.Decls is -- Create a variable declaration. -- A variable can be local only inside a function. -- ATYPE must be constrained. - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode); + procedure New_Var_Decl (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); type O_Inter_List is limited private; @@ -151,23 +152,20 @@ package Ortho_Code.Decls is -- be declared inside a subprograms. It is not allowed to declare -- o_storage_external subprograms inside a subprograms. -- Return type and interfaces cannot be a composite type. - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode); + procedure Start_Function_Decl (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode); -- For a subprogram without return value. - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage); + procedure Start_Procedure_Decl (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage); -- Add an interface declaration to INTERFACES. - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode); + procedure New_Interface_Decl (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode); -- Finish the function declaration, get the node and a statement list. procedure Finish_Subprogram_Decl (Interfaces : in out O_Inter_List; Res : out O_Dnode); diff --git a/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb index d33fe403d..b0b9a353a 100644 --- a/src/ortho/mcode/ortho_code-disps.adb +++ b/src/ortho/mcode/ortho_code-disps.adb @@ -273,18 +273,18 @@ package body Ortho_Code.Disps is begin Op := Get_Expr_Operand (Expr); case Get_Expr_Kind (Op) is - when OE_Addrg + when OE_Addrd | OE_Addrl => - Decls.Disp_Decl_Name (Get_Addr_Object (Op)); + Decls.Disp_Decl_Name (Get_Addr_Decl (Op)); when others => --Put ("*"); Disp_Expr (Op); end case; end; when OE_Addrl - | OE_Addrg => + | OE_Addrd => -- Put ('@'); - Decls.Disp_Decl_Name (Get_Addr_Object (Expr)); + Decls.Disp_Decl_Name (Get_Addr_Decl (Expr)); when OE_Call => Disp_Call (Expr); when OE_Alloca => diff --git a/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb index 4e0d6bdc4..fd467e315 100644 --- a/src/ortho/mcode/ortho_code-exprs.adb +++ b/src/ortho/mcode/ortho_code-exprs.adb @@ -160,11 +160,16 @@ package body Ortho_Code.Exprs is Enodes.Table (Enode).Arg2 := Label; end Set_Jump_Label; - function Get_Addr_Object (Enode : O_Enode) return O_Dnode is + function Get_Addr_Object (Enode : O_Enode) return O_Lnode is begin - return O_Dnode (Enodes.Table (Enode).Arg1); + return O_Lnode (Enodes.Table (Enode).Arg1); end Get_Addr_Object; + function Get_Addr_Decl (Enode : O_Enode) return O_Dnode is + begin + return O_Dnode (Enodes.Table (Enode).Arg1); + end Get_Addr_Decl; + function Get_Addrl_Frame (Enode : O_Enode) return O_Enode is begin return Enodes.Table (Enode).Arg2; @@ -492,7 +497,7 @@ package body Ortho_Code.Exprs is Save_Var : O_Dnode; begin Save_Asgn := Get_Stmt_Link (Blk); - Save_Var := Get_Addr_Object (Get_Assign_Target (Save_Asgn)); + Save_Var := Get_Addr_Decl (Get_Assign_Target (Save_Asgn)); New_Enode_Stmt (OE_Set_Stack, New_Value (New_Obj (Save_Var)), O_Enode_Null); end New_Stack_Restore; @@ -696,10 +701,8 @@ package body Ortho_Code.Exprs is function New_Lit (Lit : O_Cnode) return O_Enode is - L_Type : O_Tnode; - H, L : Uns32; + L_Type : constant O_Tnode := Get_Const_Type (Lit); begin - L_Type := Get_Const_Type (Lit); if Flag_Debug_Hli then return New_Enode (OE_Lit, L_Type, O_Enode (Lit), O_Enode_Null); else @@ -709,13 +712,18 @@ package body Ortho_Code.Exprs is | OC_Float | OC_Null | OC_Lit => - Get_Const_Bytes (Lit, H, L); - return New_Enode - (OE_Const, L_Type, - O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H))); - when OC_Address - | OC_Subprg_Address => - return New_Enode (OE_Addrg, L_Type, + declare + H, L : Uns32; + begin + Get_Const_Bytes (Lit, H, L); + return New_Enode + (OE_Const, L_Type, + O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H))); + end; + when OC_Address => + raise Syntax_Error; + when OC_Subprg_Address => + return New_Enode (OE_Addrd, L_Type, O_Enode (Get_Const_Decl (Lit)), O_Enode_Null); when OC_Array | OC_Record @@ -783,7 +791,7 @@ package body Ortho_Code.Exprs is end if; when OD_Var | OD_Const => - Kind := OE_Addrg; + Kind := OE_Addrd; Chain := O_Enode_Null; when others => raise Program_Error; diff --git a/src/ortho/mcode/ortho_code-exprs.ads b/src/ortho/mcode/ortho_code-exprs.ads index 31931702c..0bb5ec2bb 100644 --- a/src/ortho/mcode/ortho_code-exprs.ads +++ b/src/ortho/mcode/ortho_code-exprs.ads @@ -63,9 +63,9 @@ package Ortho_Code.Exprs is -- ARG1 is object. -- ARG2 is the frame pointer or O_Enode_Null for current frame pointer. OE_Addrl, - -- Address of a global variable. - -- ARG1 is object. - OE_Addrg, + -- Address of a declaration. + -- ARG1 is the declaration. + OE_Addrd, -- Pointer dereference. -- ARG1 is operand. @@ -214,7 +214,6 @@ package Ortho_Code.Exprs is subtype OE_Kind_Dyadic is OE_Kind range OE_Add_Ov .. OE_Xor; subtype OE_Kind_Cmp is OE_Kind range OE_Eq .. OE_Gt; - -- BE representation of an instruction. type O_Insn is mod 256; @@ -329,8 +328,11 @@ package Ortho_Code.Exprs is function Get_Jump_Label (Enode : O_Enode) return O_Enode; procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode); - -- Get the object of addrl,addrp,addrg - function Get_Addr_Object (Enode : O_Enode) return O_Dnode; + -- Get the declaration of addrl,addrp,addrs + function Get_Addr_Decl (Enode : O_Enode) return O_Dnode; + + -- Get the object of addrg + function Get_Addr_Object (Enode : O_Enode) return O_Lnode; -- Get the computed frame for the object. -- If O_Enode_Null, then use current frame. diff --git a/src/ortho/mcode/ortho_code-types.ads b/src/ortho/mcode/ortho_code-types.ads index da6549841..a9d15b60a 100644 --- a/src/ortho/mcode/ortho_code-types.ads +++ b/src/ortho/mcode/ortho_code-types.ads @@ -24,6 +24,8 @@ package Ortho_Code.Types is -- Optionnal. OT_Complete); + subtype OT_Kinds_Record_Union is OT_Kind range OT_Record .. OT_Union; + -- Kind of ATYPE. function Get_Type_Kind (Atype : O_Tnode) return OT_Kind; @@ -237,4 +239,3 @@ private end record; end Ortho_Code.Types; - diff --git a/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb index d76563a3e..ba9b437d9 100644 --- a/src/ortho/mcode/ortho_code-x86-abi.adb +++ b/src/ortho/mcode/ortho_code-x86-abi.adb @@ -243,7 +243,7 @@ package body Ortho_Code.X86.Abi is is use Ada.Text_IO; use Ortho_Code.Debug.Int32_IO; - Obj : constant O_Dnode := Get_Addr_Object (Stmt); + Obj : constant O_Dnode := Get_Addr_Decl (Stmt); Frame : constant O_Enode := Get_Addrl_Frame (Stmt); begin if Frame = O_Enode_Null then @@ -315,9 +315,9 @@ package body Ortho_Code.X86.Abi is case Kind is when OE_Const => Disp_Const (Stmt); - when OE_Addrg => + when OE_Addrd => Put ("&"); - Disp_Decl_Name (Get_Addr_Object (Stmt)); + Disp_Decl_Name (Get_Addr_Decl (Stmt)); when OE_Add => Disp_Irm_Code (Get_Expr_Left (Stmt)); Put ("+"); @@ -348,9 +348,9 @@ package body Ortho_Code.X86.Abi is Disp_Irm_Code (Get_Expr_Left (Stmt)); Put (" + "); Disp_Irm_Code (Get_Expr_Right (Stmt)); - when OE_Addrg => + when OE_Addrd => Put ("&"); - Disp_Decl_Name (Get_Addr_Object (Stmt)); + Disp_Decl_Name (Get_Addr_Decl (Stmt)); when others => raise Program_Error; end case; @@ -587,10 +587,10 @@ package body Ortho_Code.X86.Abi is Disp_Local (Stmt); Put (")"); New_Line; - when OE_Addrg => - Disp_Reg_Op_Name ("lea{addrg}"); + when OE_Addrd => + Disp_Reg_Op_Name ("lea{addrd}"); Put ("&"); - Disp_Decl_Name (Get_Addr_Object (Stmt)); + Disp_Decl_Name (Get_Addr_Decl (Stmt)); New_Line; when OE_Add => Disp_Reg_Op_Name ("lea{add}"); diff --git a/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb index d26a830f7..cc27a3a23 100644 --- a/src/ortho/mcode/ortho_code-x86-emits.adb +++ b/src/ortho/mcode/ortho_code-x86-emits.adb @@ -277,8 +277,8 @@ package body Ortho_Code.X86.Emits is Off := Off + To_Int32 (Get_Expr_Low (C)); P := S; end loop; - pragma Assert (Get_Expr_Kind (P) = OE_Addrg); - Sym := Get_Decl_Symbol (Get_Addr_Object (P)); + pragma Assert (Get_Expr_Kind (P) = OE_Addrd); + Sym := Get_Decl_Symbol (Get_Addr_Decl (P)); Gen_Abs (Sym, Integer_32 (Off)); end Gen_Imm_Addr; @@ -303,7 +303,7 @@ package body Ortho_Code.X86.Emits is Gen_32 (Unsigned_32 (Get_Expr_Low (N))); end case; when OE_Add - | OE_Addrg => + | OE_Addrd => -- Only for 32-bit immediat. pragma Assert (Sz = Sz_32); Gen_Imm_Addr (N); @@ -470,11 +470,11 @@ package body Ortho_Code.X86.Emits is Rm_Base := Get_Expr_Reg (Frame); end if; end; - Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Object (N)); - when OE_Addrg => + Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Decl (N)); + when OE_Addrd => -- Cannot add two symbols. pragma Assert (Rm_Sym = Null_Symbol); - Rm_Sym := Get_Decl_Symbol (Get_Addr_Object (N)); + Rm_Sym := Get_Decl_Symbol (Get_Addr_Decl (N)); when OE_Add => Fill_Sib (Get_Expr_Left (N)); Fill_Sib (Get_Expr_Right (N)); @@ -2525,10 +2525,10 @@ package body Ortho_Code.X86.Emits is -- Result is in eflags. pragma Assert (Get_Expr_Reg (Stmt) in Regs_Cc); end; - when OE_Addrg => + when OE_Addrd => pragma Assert (Mode = Abi.Mode_Ptr); if Flags.M64 - and then not Insns.Is_External_Object (Get_Addr_Object (Stmt)) + and then not Insns.Is_External_Object (Get_Addr_Decl (Stmt)) then -- Use RIP relative to load an address. Emit_Lea (Stmt); @@ -3163,8 +3163,15 @@ package body Ortho_Code.X86.Emits is when others => raise Program_Error; end case; - when OC_Address - | OC_Subprg_Address => + when OC_Address => + declare + Decl : O_Dnode; + Off : Uns32; + begin + Get_Global_Decl_Offset (Get_Const_Global (Val), Decl, Off); + Gen_Abs (Get_Decl_Symbol (Decl), Integer_32 (To_Int32 (Off))); + end; + when OC_Subprg_Address => Gen_Abs (Get_Decl_Symbol (Get_Const_Decl (Val)), 0); when OC_Array => for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop diff --git a/src/ortho/mcode/ortho_code-x86-insns.adb b/src/ortho/mcode/ortho_code-x86-insns.adb index acdcc7746..5429df016 100644 --- a/src/ortho/mcode/ortho_code-x86-insns.adb +++ b/src/ortho/mcode/ortho_code-x86-insns.adb @@ -848,7 +848,7 @@ package body Ortho_Code.X86.Insns is Set_Addrl_Frame (Expr, Reload (Spill, R_Any32, Num)); end if; return Expr; - when OE_Addrg => + when OE_Addrd => return Expr; when others => Error_Reg ("reload: unhandle expr in b_off", Expr, Dest); @@ -938,7 +938,7 @@ package body Ortho_Code.X86.Insns is if Get_Addrl_Frame (Insn) /= O_Enode_Null then Free_Insn_Regs (Get_Addrl_Frame (Insn)); end if; - when OE_Addrg => + when OE_Addrd => -- RIP-relative, no reg to free. null; when others => @@ -1358,11 +1358,11 @@ package body Ortho_Code.X86.Insns is when others => Error_Gen_Insn (Stmt, Reg); end case; - when OE_Addrg => + when OE_Addrd => if Flags.M64 then -- Use RIP-Relative addressing. if Reg = R_Sib - and then not Is_External_Object (Get_Addr_Object (Stmt)) + and then not Is_External_Object (Get_Addr_Decl (Stmt)) then Set_Expr_Reg (Stmt, R_Sib); else diff --git a/src/ortho/mcode/ortho_code.ads b/src/ortho/mcode/ortho_code.ads index 0657b07e6..489eeeccf 100644 --- a/src/ortho/mcode/ortho_code.ads +++ b/src/ortho/mcode/ortho_code.ads @@ -65,6 +65,10 @@ package Ortho_Code is for O_Lnode'Size use 32; O_Lnode_Null : constant O_Lnode := 0; + type O_Gnode is new Int32; + for O_Gnode'Size use 32; + O_Gnode_Null : constant O_Gnode := 0; + type O_Ident is new Int32; O_Ident_Nul : constant O_Ident := 0; diff --git a/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb index fac45e438..16638300d 100644 --- a/src/ortho/mcode/ortho_mcode.adb +++ b/src/ortho/mcode/ortho_mcode.adb @@ -347,22 +347,36 @@ package body Ortho_Mcode is (Ortho_Code.O_Dnode (Subprg), Ortho_Code.O_Tnode (Atype))); end New_Subprogram_Address; - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode is + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode is begin return O_Cnode (Ortho_Code.Consts.New_Global_Address - (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); + (Ortho_Code.O_Gnode (Lvalue), Ortho_Code.O_Tnode (Atype))); end New_Global_Address; - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode is begin return O_Cnode (Ortho_Code.Consts.New_Global_Unchecked_Address - (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype))); + (Ortho_Code.O_Gnode (Lvalue), Ortho_Code.O_Tnode (Atype))); end New_Global_Unchecked_Address; + function New_Global (Decl : O_Dnode) return O_Gnode is + begin + return O_Gnode + (Ortho_Code.Consts.New_Global (Ortho_Code.O_Dnode (Decl))); + end New_Global; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode is + begin + return O_Gnode + (Ortho_Code.Consts.New_Global_Selected_Element + (Ortho_Code.O_Gnode (Rec), Ortho_Code.O_Fnode (El))); + end New_Global_Selected_Element; + function New_Lit (Lit : O_Cnode) return O_Enode is begin return O_Enode (Ortho_Code.Exprs.New_Lit (Ortho_Code.O_Cnode (Lit))); diff --git a/src/ortho/mcode/ortho_mcode.ads b/src/ortho/mcode/ortho_mcode.ads index dda220f1c..515242561 100644 --- a/src/ortho/mcode/ortho_mcode.ads +++ b/src/ortho/mcode/ortho_mcode.ads @@ -41,10 +41,12 @@ package Ortho_Mcode is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -190,17 +192,17 @@ package Ortho_Mcode is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -299,12 +301,15 @@ package Ortho_Mcode is -- base type of ARR. -- INDEX must be of the type of the array index. function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -331,6 +336,9 @@ package Ortho_Mcode is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; @@ -476,9 +484,11 @@ private type O_Enode is new Ortho_Code.O_Enode; type O_Fnode is new Ortho_Code.O_Fnode; type O_Lnode is new Ortho_Code.O_Lnode; + type O_Gnode is new Ortho_Code.O_Gnode; type O_Snode is new Ortho_Code.Exprs.O_Snode; O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null); + O_Gnode_Null : constant O_Gnode := O_Gnode (Ortho_Code.O_Gnode_Null); O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null); O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null); O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null); diff --git a/src/ortho/mcode/ortho_mcode.private.ads b/src/ortho/mcode/ortho_mcode.private.ads index 5374ae978..a78a1a170 100644 --- a/src/ortho/mcode/ortho_mcode.private.ads +++ b/src/ortho/mcode/ortho_mcode.private.ads @@ -40,9 +40,11 @@ private type O_Enode is new Ortho_Code.O_Enode; type O_Fnode is new Ortho_Code.O_Fnode; type O_Lnode is new Ortho_Code.O_Lnode; + type O_Gnode is new Ortho_Code.O_Gnode; type O_Snode is new Ortho_Code.Exprs.O_Snode; O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null); + O_Gnode_Null : constant O_Gnode := O_Gnode (Ortho_Code.O_Gnode_Null); O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null); O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null); O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null); diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb index 13fdc77ae..b3d9d3a08 100644 --- a/src/ortho/oread/ortho_front.adb +++ b/src/ortho/oread/ortho_front.adb @@ -1842,9 +1842,15 @@ package body Ortho_Front is end case; end Parse_Expression; + procedure Check_Selected_Prefix (N_Type : Node_Acc) is + begin + if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union then + Parse_Error ("type of prefix is neither a record nor an union"); + end if; + end Check_Selected_Prefix; + -- Expect and leave: next token - procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc) - is + procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc) is begin loop case Tok is @@ -1858,11 +1864,7 @@ package body Ortho_Front is N_Type := N_Type.Access_Dtype; Next_Token; elsif Tok = Tok_Ident then - if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union - then - Parse_Error - ("type of prefix is neither a record nor an union"); - end if; + Check_Selected_Prefix (N_Type); declare Field : Node_Acc; begin @@ -2501,12 +2503,50 @@ package body Ortho_Front is return Res; end Parse_Address; + procedure Parse_Global_Name (Prefix : Node_Acc; + Name : out O_Gnode; N_Type : out Node_Acc) + is + begin + case Prefix.Kind is + when Node_Object => + Name := New_Global (Prefix.Obj_Node); + N_Type := Prefix.Decl_Dtype; + when others => + Parse_Error ("invalid name"); + end case; + + loop + case Tok is + when Tok_Dot => + Next_Token; + if Tok = Tok_Ident then + Check_Selected_Prefix (N_Type); + declare + Field : Node_Acc; + begin + Field := Find_Field_By_Name (N_Type); + Name := New_Global_Selected_Element (Name, + Field.Field_Fnode); + N_Type := Field.Field_Type; + Next_Token; + end; + else + Parse_Error ("'.' must be followed by a field name"); + end if; + when others => + return; + end case; + end loop; + end Parse_Global_Name; + function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode is Pfx : Node_Acc; Res : O_Cnode; Attr : Syment_Acc; T : O_Tnode; + N : O_Gnode; + N_Type : Node_Acc; begin Attr := Token_Sym; Next_Expect (Tok_Left_Paren); @@ -2523,10 +2563,11 @@ package body Ortho_Front is Next_Token; else Next_Token; + Parse_Global_Name (Pfx, N, N_Type); if Attr = Id_Address then - Res := New_Global_Address (Pfx.Obj_Node, T); + Res := New_Global_Address (N, T); elsif Attr = Id_Unchecked_Address then - Res := New_Global_Unchecked_Address (Pfx.Obj_Node, T); + Res := New_Global_Unchecked_Address (N, T); else Parse_Error ("address attribute expected"); end if; diff --git a/src/ortho/ortho_nodes.common.ads b/src/ortho/ortho_nodes.common.ads index d0f22b720..30e44d6fd 100644 --- a/src/ortho/ortho_nodes.common.ads +++ b/src/ortho/ortho_nodes.common.ads @@ -28,10 +28,12 @@ package ORTHO_NODES is type O_Tnode is private; type O_Snode is private; type O_Dnode is private; + type O_Gnode is private; type O_Fnode is private; O_Cnode_Null : constant O_Cnode; O_Dnode_Null : constant O_Dnode; + O_Gnode_Null : constant O_Gnode; O_Enode_Null : constant O_Enode; O_Fnode_Null : constant O_Fnode; O_Lnode_Null : constant O_Lnode; @@ -177,17 +179,17 @@ package ORTHO_NODES is -- Get the address of a subprogram. function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode; + return O_Cnode; -- Get the address of LVALUE. -- ATYPE must be a type access whose designated type is the type of LVALUE. -- FIXME: what about arrays. - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) return O_Cnode; -- Same as New_Address but without any restriction. - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode; + function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) + return O_Cnode; ------------------- -- Expressions -- @@ -286,12 +288,15 @@ package ORTHO_NODES is -- base type of ARR. -- INDEX must be of the type of the array index. function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode; + return O_Lnode; -- Get an element of a record or a union. -- Type of REC must be a record or a union type. function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode; + return O_Lnode; + + function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) + return O_Gnode; -- Reference an access. -- Type of ACC must be an access type. @@ -318,6 +323,9 @@ package ORTHO_NODES is -- Get an lvalue from a declaration. function New_Obj (Obj : O_Dnode) return O_Lnode; + -- Get a global lvalue from a declaration. + function New_Global (Decl : O_Dnode) return O_Gnode; + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads index fdc34ebcd..b88b35217 100644 --- a/src/vhdl/iirs.ads +++ b/src/vhdl/iirs.ads @@ -1798,7 +1798,7 @@ package Iirs is -- -- Get/Set_Type (Field1) -- - -- Corresponding element_declaration. FIXME: remove as supersided by + -- Corresponding element_declaration. FIXME: remove as superseeded by -- element_position. -- Get/Set_Element_Declaration (Field5) -- diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb index 8cc5fbf74..971962288 100644 --- a/src/vhdl/sem_assocs.adb +++ b/src/vhdl/sem_assocs.adb @@ -1012,6 +1012,8 @@ package body Sem_Assocs is if Get_Constraint_State (Atype) /= Fully_Constrained then -- Some (sub-)elements are unbounded, create a bounded subtype. declare + Inter : constant Iir := + Get_Interface_Of_Formal (Get_Formal (Assoc)); Ntype : Iir; Nel_List : Iir_Flist; Nrec_El : Iir; @@ -1025,6 +1027,12 @@ package body Sem_Assocs is Set_Resolution_Indication (Ntype, Get_Resolution_Indication (Atype)); end if; + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration + then + -- The subtype is used for signals. + Set_Has_Signal_Flag (Ntype, True); + end if; + Nel_List := Create_Iir_Flist (Nbr_El); Set_Elements_Declaration_List (Ntype, Nel_List); @@ -1096,7 +1104,7 @@ package body Sem_Assocs is -- individual association ASSOC: compute bounds, detect missing elements. procedure Finish_Individual_Association (Assoc : Iir) is - Formal : Iir; + Inter : Iir; Atype : Iir; begin -- Guard. @@ -1104,8 +1112,8 @@ package body Sem_Assocs is return; end if; - Formal := Get_Interface_Of_Formal (Get_Formal (Assoc)); - Atype := Get_Type (Formal); + Inter := Get_Interface_Of_Formal (Get_Formal (Assoc)); + Atype := Get_Type (Inter); Set_Whole_Association_Flag (Assoc, True); case Get_Kind (Atype) is @@ -1118,6 +1126,11 @@ package body Sem_Assocs is Atype := Create_Array_Subtype (Atype, Get_Location (Assoc)); Set_Index_Constraint_Flag (Atype, True); Set_Constraint_State (Atype, Fully_Constrained); + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration + then + -- The subtype is used for signals. + Set_Has_Signal_Flag (Atype, True); + end if; Set_Actual_Type (Assoc, Atype); Set_Actual_Type_Definition (Assoc, Atype); Finish_Individual_Assoc_Array (Assoc, Assoc, 1); diff --git a/src/vhdl/sem_types.adb b/src/vhdl/sem_types.adb index 843f549e4..47432e140 100644 --- a/src/vhdl/sem_types.adb +++ b/src/vhdl/sem_types.adb @@ -1394,6 +1394,31 @@ package body Sem_Types is (Def : Iir; Type_Mark : Iir; Resolution : Iir) return Iir; + function Copy_Record_Element_Declaration (El : Iir; Parent : Iir) return Iir + is + New_El : Iir; + begin + case Get_Kind (El) is + when Iir_Kind_Element_Declaration => + New_El := Create_Iir (Iir_Kind_Element_Declaration); + -- As this is a copy, it has no subtype indication. + Set_Subtype_Indication (New_El, Null_Iir); + when Iir_Kind_Record_Element_Constraint => + New_El := Create_Iir (Iir_Kind_Record_Element_Constraint); + Set_Element_Declaration (New_El, Get_Element_Declaration (El)); + when others => + Error_Kind ("copy_record_element_declaration", El); + end case; + Location_Copy (New_El, El); + Set_Parent (New_El, Parent); + Set_Identifier (New_El, Get_Identifier (El)); + Set_Type (New_El, Get_Type (El)); + Set_Base_Element_Declaration + (New_El, Get_Base_Element_Declaration (El)); + Set_Element_Position (New_El, Get_Element_Position (El)); + return New_El; + end Copy_Record_Element_Declaration; + -- Create a copy of elements_declaration_list of SRC and set it to DST. procedure Copy_Record_Elements_Declaration_List (Dst : Iir; Src : Iir) is @@ -1405,14 +1430,7 @@ package body Sem_Types is Set_Elements_Declaration_List (Dst, New_El_List); for I in Flist_First .. Flist_Last (El_List) loop El := Get_Nth_Element (El_List, I); - New_El := Create_Iir (Iir_Kind_Element_Declaration); - Location_Copy (New_El, El); - Set_Parent (New_El, Dst); - Set_Identifier (New_El, Get_Identifier (El)); - Set_Type (New_El, Get_Type (El)); - Set_Base_Element_Declaration (New_El, - Get_Base_Element_Declaration (El)); - Set_Element_Position (New_El, Get_Element_Position (El)); + New_El := Copy_Record_Element_Declaration (El, Dst); Set_Nth_Element (New_El_List, I, New_El); end loop; end Copy_Record_Elements_Declaration_List; @@ -2030,7 +2048,7 @@ package body Sem_Types is if Els (I) = Null_Iir and Res_Els (I) = Null_Iir then -- No new record element constraints. Copy the element from -- the type mark. - El := Tm_El; + El := Copy_Record_Element_Declaration (Tm_El, Res); El_Type := Get_Type (El); else if Els (I) = Null_Iir then diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb index cad732752..dfd50856c 100644 --- a/src/vhdl/translate/trans-chap12.adb +++ b/src/vhdl/translate/trans-chap12.adb @@ -85,11 +85,9 @@ package body Trans.Chap12 is (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Elab_Nbr_Pkgs)))); New_Association - (Assoc, New_Lit (New_Global_Address - (Pkgs_Arr, Rtis.Ghdl_Rti_Arr_Acc))); + (Assoc, New_Address (New_Obj (Pkgs_Arr), Rtis.Ghdl_Rti_Arr_Acc)); New_Association - (Assoc, - New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const))); + (Assoc, Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const)); New_Association (Assoc, New_Convert_Ov (Arch_Instance, Ghdl_Ptr_Type)); New_Procedure_Call (Assoc); @@ -98,8 +96,7 @@ package body Trans.Chap12 is Start_Association (Assoc, Ghdl_Rti_Add_Package); New_Association (Assoc, - New_Lit (Rtis.New_Rti_Address - (Get_Info (Standard_Package).Package_Rti_Const))); + Rtis.New_Rti_Address (Get_Info (Standard_Package).Package_Rti_Const)); New_Procedure_Call (Assoc); end Call_Elab_Decls; diff --git a/src/vhdl/translate/trans-chap14.adb b/src/vhdl/translate/trans-chap14.adb index 2e554d556..b35cc9f81 100644 --- a/src/vhdl/translate/trans-chap14.adb +++ b/src/vhdl/translate/trans-chap14.adb @@ -809,8 +809,7 @@ package body Trans.Chap14 is | Type_Mode_E32 | Type_Mode_P32 | Type_Mode_P64 => - New_Association - (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); + New_Association (Assoc, Rtis.New_Rti_Address (Pinfo.Type_Rti)); when Type_Mode_I32 | Type_Mode_I64 | Type_Mode_F64 => @@ -857,8 +856,7 @@ package body Trans.Chap14 is | Type_Mode_E32 | Type_Mode_P32 | Type_Mode_P64 => - New_Association - (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); + New_Association (Assoc, Rtis.New_Rti_Address (Pinfo.Type_Rti)); when Type_Mode_I32 | Type_Mode_I64 | Type_Mode_F64 => diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb index 60040ea2e..374879857 100644 --- a/src/vhdl/translate/trans-chap2.adb +++ b/src/vhdl/translate/trans-chap2.adb @@ -1024,8 +1024,7 @@ package body Trans.Chap2 is -- instantiated due to generate statements). Start_Association (Constr, Ghdl_Rti_Add_Package); New_Association - (Constr, - New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const))); + (Constr, Rtis.New_Rti_Address (Info.Package_Rti_Const)); New_Procedure_Call (Constr); end if; @@ -1160,7 +1159,12 @@ package body Trans.Chap2 is null; when Kind_Type_Array | Kind_Type_Record => - null; + B.Builder (Mode_Value).Builder_Instance := + Instantiate_Subprg_Instance + (Orig.Builder (Mode_Value).Builder_Instance); + B.Builder (Mode_Signal).Builder_Instance := + Instantiate_Subprg_Instance + (Orig.Builder (Mode_Signal).Builder_Instance); when Kind_Type_File => null; when Kind_Type_Protected => @@ -1187,7 +1191,7 @@ package body Trans.Chap2 is Res.Range_Var := Instantiate_Var (Src.Range_Var); when Kind_Type_Array | Kind_Type_Record => - Res.Composite_Bounds := Instantiate_Var (Src.Composite_Bounds); + Res.Composite_Layout := Instantiate_Var (Src.Composite_Layout); when Kind_Type_File => null; when Kind_Type_Protected => @@ -1206,45 +1210,13 @@ package body Trans.Chap2 is Type_Incomplete => Src.Type_Incomplete, Type_Locally_Constrained => Src.Type_Locally_Constrained, - C => null, Ortho_Type => Src.Ortho_Type, Ortho_Ptr_Type => Src.Ortho_Ptr_Type, B => Src.B, S => Copy_Info_Subtype (Src.S), Type_Rti => Src.Type_Rti); Adjust_Info_Basetype (Dest.B'Unrestricted_Access, - Src.B'Unrestricted_Access); - if Src.C /= null then - Dest.C := new Complex_Type_Arr_Info' - (Mode_Value => - (Mark => False, - Size_Var => Instantiate_Var - (Src.C (Mode_Value).Size_Var), - Builder_Need_Func => - Src.C (Mode_Value).Builder_Need_Func, - Builder_Instance => Instantiate_Subprg_Instance - (Src.C (Mode_Value).Builder_Instance), - Builder_Base_Param => - Src.C (Mode_Value).Builder_Base_Param, - Builder_Bound_Param => - Src.C (Mode_Value).Builder_Bound_Param, - Builder_Func => - Src.C (Mode_Value).Builder_Func), - Mode_Signal => - (Mark => False, - Size_Var => Instantiate_Var - (Src.C (Mode_Signal).Size_Var), - Builder_Need_Func => - Src.C (Mode_Signal).Builder_Need_Func, - Builder_Instance => Instantiate_Subprg_Instance - (Src.C (Mode_Signal).Builder_Instance), - Builder_Base_Param => - Src.C (Mode_Signal).Builder_Base_Param, - Builder_Bound_Param => - Src.C (Mode_Signal).Builder_Bound_Param, - Builder_Func => - Src.C (Mode_Signal).Builder_Func)); - end if; + Src.B'Unrestricted_Access); when Kind_Object => Dest.all := (Kind => Kind_Object, diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb index ced7e1a94..624b95a25 100644 --- a/src/vhdl/translate/trans-chap3.adb +++ b/src/vhdl/translate/trans-chap3.adb @@ -32,8 +32,6 @@ with Translation; package body Trans.Chap3 is use Trans.Helpers; - function Unbox_Record (Arr : Mnode) return Mnode; - function Create_Static_Type_Definition_Type_Range (Def : Iir) return O_Cnode; procedure Elab_Scalar_Type_Range (Def : Iir; Target : O_Lnode); @@ -43,11 +41,114 @@ package body Trans.Chap3 is Base : Iir; Subtype_Info : Type_Info_Acc); + function Get_Composite_Type_Layout (Info : Type_Info_Acc) return Mnode + is + begin + case Info.Type_Mode is + when Type_Mode_Unbounded => + raise Internal_Error; + when Type_Mode_Bounded_Arrays + | Type_Mode_Bounded_Records => + return Varv2M (Info.S.Composite_Layout, + Info, Mode_Value, + Info.B.Layout_Type, + Info.B.Layout_Ptr_Type); + when others => + raise Internal_Error; + end case; + end Get_Composite_Type_Layout; + + function Layout_To_Bounds (B : Mnode) return Mnode + is + Info : constant Type_Info_Acc := Get_Type_Info (B); + begin + case Info.Type_Mode is + when Type_Mode_Arrays => + return Lv2M (New_Selected_Element (M2Lv (B), Info.B.Layout_Bounds), + Info, Mode_Value, + Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type); + when Type_Mode_Records => + return B; + when others => + raise Internal_Error; + end case; + end Layout_To_Bounds; + + function Layout_To_Sizes (B : Mnode) return O_Lnode + is + Info : constant Type_Info_Acc := Get_Type_Info (B); + begin + return New_Selected_Element (M2Lv (B), Info.B.Layout_Size); + end Layout_To_Sizes; + + function Layout_To_Sizes (B : Mnode) return Mnode is + begin + return Lv2M (Layout_To_Sizes (B), Get_Type_Info (B), Mode_Value, + Ghdl_Sizes_Type, Ghdl_Sizes_Ptr); + end Layout_To_Sizes; + + function Sizes_To_Size (Sizes : O_Lnode; Kind : Object_Kind_Type) + return O_Lnode + is + Field : O_Fnode; + begin + case Kind is + when Mode_Value => + Field := Ghdl_Sizes_Val; + when Mode_Signal => + Field := Ghdl_Sizes_Sig; + end case; + return New_Selected_Element (Sizes, Field); + end Sizes_To_Size; + + function Layout_To_Size (Layout : Mnode; Kind : Object_Kind_Type) + return O_Lnode is + begin + return Sizes_To_Size (M2Lv (Layout_To_Sizes (Layout)), Kind); + end Layout_To_Size; + + function Record_Layout_To_Element_Layout (B : Mnode; El : Iir) return Mnode + is + El_Type : constant Iir := Get_Type (El); + El_Info : constant Field_Info_Acc := Get_Info (El); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + begin + return Lv2M (New_Selected_Element (M2Lv (B), + El_Info.Field_Bound), + El_Tinfo, Mode_Value, + El_Tinfo.B.Layout_Type, El_Tinfo.B.Layout_Ptr_Type); + end Record_Layout_To_Element_Layout; + + function Record_Layout_To_Element_Offset + (B : Mnode; El : Iir; Kind : Object_Kind_Type) return O_Lnode + is + El_Info : constant Field_Info_Acc := Get_Info (El); + begin + return New_Selected_Element (M2Lv (B), El_Info.Field_Node (Kind)); + end Record_Layout_To_Element_Offset; + + function Array_Bounds_To_Element_Layout (B : Mnode; Atype : Iir) + return Mnode + is + Arr_Tinfo : constant Type_Info_Acc := Get_Info (Atype); + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + begin + return Lv2M (New_Selected_Element (M2Lv (B), Arr_Tinfo.B.Bounds_El), + El_Tinfo, Mode_Value, + El_Tinfo.B.Layout_Type, El_Tinfo.B.Layout_Ptr_Type); + end Array_Bounds_To_Element_Layout; + + function Array_Layout_To_Element_Layout (B : Mnode; Arr_Type : Iir) + return Mnode is + begin + return Array_Bounds_To_Element_Layout (Layout_To_Bounds (B), Arr_Type); + end Array_Layout_To_Element_Layout; + -- Finish a type definition: declare the type, define and declare a -- pointer to the type. procedure Finish_Type_Definition - (Info : Type_Info_Acc; Completion : Boolean := False) - is + (Info : Type_Info_Acc; Completion : Boolean := False) is begin -- Declare the type. if not Completion then @@ -83,31 +184,6 @@ package body Trans.Chap3 is end if; end Finish_Type_Definition; - procedure Set_Complex_Type (Info : Type_Info_Acc; Need_Builder : Boolean) is - begin - pragma Assert (Info.C = null); - Info.C := new Complex_Type_Arr_Info; - -- No size variable for unconstrained array type. - for Mode in Object_Kind_Type loop - Info.C (Mode).Builder_Need_Func := Need_Builder; - end loop; - end Set_Complex_Type; - - procedure Copy_Complex_Type (Dest : Type_Info_Acc; Src : Type_Info_Acc) is - begin - Dest.C := new Complex_Type_Arr_Info'(Src.C.all); - end Copy_Complex_Type; - - procedure Create_Size_Var (Def : Iir; Info : Type_Info_Acc) is - begin - Info.C (Mode_Value).Size_Var := Create_Var - (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); - if Get_Has_Signal_Flag (Def) then - Info.C (Mode_Signal).Size_Var := Create_Var - (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type); - end if; - end Create_Size_Var; - -- A builder set internal fields of object pointed by BASE_PTR, using -- memory from BASE_PTR and returns a pointer to the next memory byte -- to be used. @@ -117,7 +193,6 @@ package body Trans.Chap3 is is Interface_List : O_Inter_List; Ident : O_Ident; - Ptype : O_Tnode; begin case Kind is when Mode_Value => @@ -126,63 +201,27 @@ package body Trans.Chap3 is Ident := Create_Identifier (Name, "_SIGBUILDER"); end case; -- FIXME: return the same type as its first parameter ??? - Start_Function_Decl - (Interface_List, Ident, Global_Storage, Ghdl_Index_Type); + Start_Procedure_Decl (Interface_List, Ident, Global_Storage); Subprgs.Add_Subprg_Instance_Interfaces - (Interface_List, Info.C (Kind).Builder_Instance); - case Info.Type_Mode is - when Type_Mode_Unbounded => - Ptype := Info.B.Base_Ptr_Type (Kind); - when Type_Mode_Complex_Record => - Ptype := Info.Ortho_Ptr_Type (Kind); - when others => - raise Internal_Error; - end case; + (Interface_List, Info.B.Builder (Kind).Builder_Instance); New_Interface_Decl - (Interface_List, Info.C (Kind).Builder_Base_Param, - Get_Identifier ("base_ptr"), Ptype); - -- Add parameter for array bounds. - if Info.Type_Mode in Type_Mode_Unbounded then - New_Interface_Decl - (Interface_List, Info.C (Kind).Builder_Bound_Param, - Get_Identifier ("bound"), Info.B.Bounds_Ptr_Type); - end if; - Finish_Subprogram_Decl (Interface_List, Info.C (Kind).Builder_Func); + (Interface_List, Info.B.Builder (Kind).Builder_Layout_Param, + Get_Identifier ("layout_ptr"), Info.B.Layout_Ptr_Type); + Finish_Subprogram_Decl + (Interface_List, Info.B.Builder (Kind).Builder_Proc); end Create_Builder_Subprogram_Decl; - function Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir) return O_Enode + procedure Gen_Call_Type_Builder + (Layout : Mnode; Var_Type : Iir; Kind : Object_Kind_Type) is - Kind : constant Object_Kind_Type := Get_Object_Kind (Var); Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type)); Assoc : O_Assoc_List; begin - -- Build the field - Start_Association (Assoc, Binfo.C (Kind).Builder_Func); + Start_Association (Assoc, Binfo.B.Builder (Kind).Builder_Proc); Subprgs.Add_Subprg_Instance_Assoc - (Assoc, Binfo.C (Kind).Builder_Instance); - - -- Note: a fat array can only be at the top of a complex type; - -- the bounds must have been set. - New_Association - (Assoc, M2Addr (Chap3.Get_Composite_Base (Var))); - - if Binfo.Type_Mode in Type_Mode_Unbounded then - New_Association (Assoc, M2Addr (Chap3.Get_Composite_Bounds (Var))); - end if; - - return New_Function_Call (Assoc); - end Gen_Call_Type_Builder; - - procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir) - is - Mem : O_Dnode; - V : Mnode; - begin - Open_Temp; - V := Stabilize (Var); - Mem := Create_Temp (Ghdl_Index_Type); - New_Assign_Stmt (New_Obj (Mem), Gen_Call_Type_Builder (V, Var_Type)); - Close_Temp; + (Assoc, Binfo.B.Builder (Kind).Builder_Instance); + New_Association (Assoc, M2Addr (Layout)); + New_Procedure_Call (Assoc); end Gen_Call_Type_Builder; ------------------ @@ -246,8 +285,10 @@ package body Trans.Chap3 is Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value)); if Nbr <= 256 then Info.Type_Mode := Type_Mode_E8; + Info.B.Align := Align_8; else Info.Type_Mode := Type_Mode_E32; + Info.B.Align := Align_32; end if; -- Enumerations are always in their range. Info.S.Nocheck_Low := True; @@ -275,6 +316,7 @@ package body Trans.Chap3 is Set_Ortho_Expr (True_Lit, True_Node); Info.S.Nocheck_Low := True; Info.S.Nocheck_Hi := True; + Info.B.Align := Align_8; Finish_Type_Definition (Info); end Translate_Bool_Type; @@ -315,9 +357,11 @@ package body Trans.Chap3 is when Precision_32 => Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); Info.Type_Mode := Type_Mode_I32; + Info.B.Align := Align_32; when Precision_64 => Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); Info.Type_Mode := Type_Mode_I64; + Info.B.Align := Align_64; end case; -- Integers are always in their ranges. Info.S.Nocheck_Low := True; @@ -336,6 +380,7 @@ package body Trans.Chap3 is begin -- FIXME: should check precision Info.Type_Mode := Type_Mode_F64; + Info.B.Align := Align_64; Info.Ortho_Type (Mode_Value) := New_Float_Type; -- Reals are always in their ranges. Info.S.Nocheck_Low := True; @@ -356,9 +401,11 @@ package body Trans.Chap3 is when Precision_32 => Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); Info.Type_Mode := Type_Mode_P32; + Info.B.Align := Align_32; when Precision_64 => Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); Info.Type_Mode := Type_Mode_P64; + Info.B.Align := Align_64; end case; -- Physical types are always in their ranges. Info.S.Nocheck_Low := True; @@ -394,6 +441,7 @@ package body Trans.Chap3 is Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type; Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type; Info.Type_Mode := Type_Mode_File; + Info.B.Align := Align_32; end Translate_File_Type; function Get_File_Signature_Length (Def : Iir) return Natural is @@ -503,6 +551,7 @@ package body Trans.Chap3 is procedure Create_Unbounded_Type_Fat_Pointer (Info : Type_Info_Acc) is Constr : O_Element_List; + Bounds_Type : O_Tnode; begin for Kind in Object_Kind_Type loop exit when Info.B.Base_Type (Kind) = O_Tnode_Null; @@ -511,9 +560,17 @@ package body Trans.Chap3 is New_Record_Field (Constr, Info.B.Base_Field (Kind), Wki_Base, Info.B.Base_Ptr_Type (Kind)); + case Info.Type_Mode is + when Type_Mode_Unbounded_Array => + Bounds_Type := Info.B.Bounds_Ptr_Type; + when Type_Mode_Unbounded_Record => + Bounds_Type := Info.B.Layout_Ptr_Type; + when others => + raise Internal_Error; + end case; New_Record_Field (Constr, Info.B.Bounds_Field (Kind), Wki_Bounds, - Info.B.Bounds_Ptr_Type); + Bounds_Type); Finish_Record_Type (Constr, Info.Ortho_Type (Kind)); end loop; end Create_Unbounded_Type_Fat_Pointer; @@ -550,89 +607,129 @@ package body Trans.Chap3 is New_Type_Decl (Create_Identifier ("BOUNDP"), Info.B.Bounds_Ptr_Type); end Finish_Unbounded_Type_Bounds; - function Create_Static_Composite_Subtype_Bounds (Def : Iir) return O_Cnode + function Create_Static_Composite_Subtype_Sizes (Def : Iir) return O_Cnode + is + Info : constant Type_Info_Acc := Get_Info (Def); + Sz_List : O_Record_Aggr_List; + Sz : O_Cnode; + Sz_Res : O_Cnode; + begin + Start_Record_Aggr (Sz_List, Ghdl_Sizes_Type); + New_Record_Aggr_El + (Sz_List, New_Sizeof (Info.Ortho_Type (Mode_Value), Ghdl_Index_Type)); + if Get_Has_Signal_Flag (Def) then + Sz := New_Sizeof (Info.Ortho_Type (Mode_Signal), Ghdl_Index_Type); + else + Sz := Ghdl_Index_0; + end if; + New_Record_Aggr_El (Sz_List, Sz); + Finish_Record_Aggr (Sz_List, Sz_Res); + return Sz_Res; + end Create_Static_Composite_Subtype_Sizes; + + function Create_Static_Array_Subtype_Bounds (Def : Iir) return O_Cnode is - Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def)); + Base_Type : constant Iir := Get_Base_Type (Def); + Binfo : constant Type_Info_Acc := Get_Info (Base_Type); + Indexes_List : constant Iir_Flist := Get_Index_Subtype_List (Def); + Index : Iir; List : O_Record_Aggr_List; Res : O_Cnode; begin Start_Record_Aggr (List, Binfo.B.Bounds_Type); - case Get_Kind (Def) is - when Iir_Kind_Array_Subtype_Definition => - declare - Indexes_List : constant Iir_Flist := - Get_Index_Subtype_List (Def); - Index : Iir; - begin - for I in Flist_First .. Flist_Last (Indexes_List) loop - Index := Get_Index_Type (Indexes_List, I); - New_Record_Aggr_El - (List, Create_Static_Type_Definition_Type_Range (Index)); - end loop; - end; - if Binfo.B.El_Size /= O_Fnode_Null then - -- For arrays of unbounded type. - declare - El_Type : constant Iir := Get_Element_Subtype (Def); - El_Info : constant Type_Info_Acc := Get_Info (El_Type); - Sz_List : O_Record_Aggr_List; - Sz_Res : O_Cnode; - begin - New_Record_Aggr_El - (List, Create_Static_Composite_Subtype_Bounds (El_Type)); - - Start_Record_Aggr (Sz_List, Ghdl_Sizes_Type); - New_Record_Aggr_El - (Sz_List, New_Sizeof (El_Info.Ortho_Type (Mode_Value), - Ghdl_Index_Type)); - New_Record_Aggr_El - (Sz_List, New_Sizeof (El_Info.Ortho_Type (Mode_Signal), - Ghdl_Index_Type)); - Finish_Record_Aggr (Sz_List, Sz_Res); - New_Record_Aggr_El (List, Sz_Res); - end; - end if; + for I in Flist_First .. Flist_Last (Indexes_List) loop + Index := Get_Index_Type (Indexes_List, I); + New_Record_Aggr_El + (List, Create_Static_Type_Definition_Type_Range (Index)); + end loop; - when Iir_Kind_Record_Subtype_Definition => - declare - El_List : constant Iir_Flist := - Get_Elements_Declaration_List (Def); - El_Blist : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Def)); - El : Iir; - Bel : Iir; - Bel_Info : Field_Info_Acc; - begin - for I in Flist_First .. Flist_Last (El_Blist) loop - Bel := Get_Nth_Element (El_Blist, I); - Bel_Info := Get_Info (Bel); - if Bel_Info.Field_Bound /= O_Fnode_Null then - El := Get_Nth_Element (El_List, I); - New_Record_Aggr_El - (List, - Create_Static_Composite_Subtype_Bounds - (Get_Type (El))); - end if; - end loop; - end; + if Binfo.B.Bounds_El /= O_Fnode_Null then + -- For arrays of unbounded type. + New_Record_Aggr_El + (List, Create_Static_Composite_Subtype_Layout + (Get_Element_Subtype (Def))); + end if; - when others => - Error_Kind ("create_static_composite_subtype_bounds", Def); - end case; + Finish_Record_Aggr (List, Res); + return Res; + end Create_Static_Array_Subtype_Bounds; + + function Create_Static_Record_Subtype_Bounds (Def : Iir) return O_Cnode + is + Base_Type : constant Iir := Get_Base_Type (Def); + Binfo : constant Type_Info_Acc := Get_Info (Base_Type); + El_List : constant Iir_Flist := Get_Elements_Declaration_List (Def); + El_Blist : constant Iir_Flist := + Get_Elements_Declaration_List (Base_Type); + Info : constant Type_Info_Acc := Get_Info (Def); + List : O_Record_Aggr_List; + Res : O_Cnode; + El : Iir; + Bel : Iir; + Bel_Info : Field_Info_Acc; + El_Info : Field_Info_Acc; + Off : O_Cnode; + begin + Start_Record_Aggr (List, Binfo.B.Bounds_Type); + + New_Record_Aggr_El (List, Create_Static_Composite_Subtype_Sizes (Def)); + + for I in Flist_First .. Flist_Last (El_Blist) loop + Bel := Get_Nth_Element (El_Blist, I); + Bel_Info := Get_Info (Bel); + if Bel_Info.Field_Bound /= O_Fnode_Null then + El := Get_Nth_Element (El_List, I); + El_Info := Get_Info (El); + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Base_Type) + loop + if Info.Ortho_Type (Kind) /= O_Tnode_Null then + Off := New_Offsetof (Info.Ortho_Type (Kind), + El_Info.Field_Node (Kind), + Ghdl_Index_Type); + else + Off := Ghdl_Index_0; + end if; + New_Record_Aggr_El (List, Off); + end loop; + New_Record_Aggr_El + (List, Create_Static_Composite_Subtype_Layout (Get_Type (El))); + end if; + end loop; Finish_Record_Aggr (List, Res); return Res; - end Create_Static_Composite_Subtype_Bounds; + end Create_Static_Record_Subtype_Bounds; - procedure Elab_Composite_Subtype_Bounds (Def : Iir; Target : O_Lnode) + function Create_Static_Composite_Subtype_Layout (Def : Iir) return O_Cnode is - Info : constant Type_Info_Acc := Get_Info (Def); - Base_Type : constant Iir := Get_Base_Type (Def); - Targ : Mnode; + Info : constant Type_Info_Acc := Get_Info (Def); + begin + case Info.Type_Mode is + when Type_Mode_Static_Record + | Type_Mode_Complex_Record => + return Create_Static_Record_Subtype_Bounds (Def); + when Type_Mode_Static_Array + | Type_Mode_Complex_Array => + declare + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Start_Record_Aggr (List, Info.B.Layout_Type); + New_Record_Aggr_El + (List, Create_Static_Composite_Subtype_Sizes (Def)); + New_Record_Aggr_El + (List, Create_Static_Array_Subtype_Bounds (Def)); + Finish_Record_Aggr (List, Res); + return Res; + end; + when others => + raise Internal_Error; + end case; + end Create_Static_Composite_Subtype_Layout; + + procedure Elab_Composite_Subtype_Layout (Def : Iir; Target : Mnode) is begin - Targ := Lv2M (Target, null, Mode_Value, - Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type); Open_Temp; case Get_Kind (Def) is @@ -640,110 +737,101 @@ package body Trans.Chap3 is declare Indexes_List : constant Iir_Flist := Get_Index_Subtype_List (Def); - Indexes_Def_List : constant Iir_Flist := - Get_Index_Subtype_Definition_List (Base_Type); + Targ : Mnode; Index : Iir; begin + Targ := Layout_To_Bounds (Target); if Get_Nbr_Elements (Indexes_List) > 1 then Targ := Stabilize (Targ); end if; for I in Flist_First .. Flist_Last (Indexes_List) loop Index := Get_Index_Type (Indexes_List, I); - declare - Index_Type : constant Iir := Get_Base_Type (Index); - Index_Info : constant Type_Info_Acc := - Get_Info (Index_Type); - Base_Index_Info : constant Index_Info_Acc := - Get_Info (Get_Nth_Element (Indexes_Def_List, I)); - D : O_Dnode; - begin - Open_Temp; - D := Create_Temp_Ptr - (Index_Info.B.Range_Ptr_Type, - New_Selected_Element (M2Lv (Targ), - Base_Index_Info.Index_Field)); - Chap7.Translate_Discrete_Range - (Dp2M (D, Index_Info, Mode_Value, - Index_Info.B.Range_Type, - Index_Info.B.Range_Ptr_Type), - Index); - Close_Temp; - end; + Open_Temp; + Chap7.Translate_Discrete_Range + (Bounds_To_Range (Targ, Def, I + 1), Index); + Close_Temp; end loop; + -- FIXME: element ? end; + when Iir_Kind_Record_Type_Definition => + null; + when Iir_Kind_Record_Subtype_Definition => declare El_List : constant Iir_Flist := Get_Elements_Declaration_List (Def); + Targ : Mnode; El : Iir; - El_Info : Field_Info_Acc; + Base_El : Iir; begin - Targ := Stabilize (Targ); + Targ := Stabilize (Target); for I in Flist_First .. Flist_Last (El_List) loop El := Get_Nth_Element (El_List, I); - El_Info := Get_Info (Get_Base_Element_Declaration (El)); - if El_Info.Field_Bound /= O_Fnode_Null then - Elab_Composite_Subtype_Bounds + Base_El := Get_Base_Element_Declaration (El); + if Is_Unbounded_Type (Get_Info (Get_Type (Base_El))) then + Elab_Composite_Subtype_Layout (Get_Type (El), - New_Selected_Element (M2Lv (Targ), - El_Info.Field_Bound)); + Record_Layout_To_Element_Layout (Targ, El)); end if; end loop; end; when others => - Error_Kind ("elab_composite_subtype_bounds", Def); + Error_Kind ("elab_composite_subtype_layout", Def); end case; Close_Temp; - end Elab_Composite_Subtype_Bounds; + end Elab_Composite_Subtype_Layout; - procedure Elab_Composite_Subtype_Bounds (Def : Iir) + procedure Elab_Composite_Subtype_Layout (Def : Iir) is Info : constant Type_Info_Acc := Get_Info (Def); begin - if not Info.S.Static_Bounds then - Elab_Composite_Subtype_Bounds - (Def, Get_Var (Info.S.Composite_Bounds)); + if Is_Complex_Type (Info) then + Elab_Composite_Subtype_Layout (Def, Get_Composite_Type_Layout (Info)); + + Gen_Call_Type_Builder + (Get_Composite_Type_Layout (Info), Def, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Gen_Call_Type_Builder + (Get_Composite_Type_Layout (Info), Def, Mode_Signal); + end if; end if; - end Elab_Composite_Subtype_Bounds; + end Elab_Composite_Subtype_Layout; - -- Create a variable containing the bounds for array subtype DEF. - procedure Create_Composite_Subtype_Bounds_Var + -- Create a variable containing the layout for composite subtype DEF. + procedure Create_Composite_Subtype_Layout_Var (Def : Iir; Elab_Now : Boolean) is Info : constant Type_Info_Acc := Get_Info (Def); - Base_Info : Type_Info_Acc; Val : O_Cnode; begin - if Info.S.Composite_Bounds /= Null_Var then + if Info.S.Composite_Layout /= Null_Var then + -- Already created. return; end if; - Base_Info := Get_Info (Get_Base_Type (Def)); if Are_Bounds_Locally_Static (Def) then - Info.S.Static_Bounds := True; if Global_Storage = O_Storage_External then -- Do not create the value of the type desc, since it -- is never dereferenced in a static type desc. Val := O_Cnode_Null; else - Val := Create_Static_Composite_Subtype_Bounds (Def); + Val := Create_Static_Composite_Subtype_Layout (Def); end if; - Info.S.Composite_Bounds := Create_Global_Const - (Create_Identifier ("STB"), - Base_Info.B.Bounds_Type, Global_Storage, Val); + Info.S.Composite_Layout := Create_Global_Const + (Create_Identifier ("STL"), + Info.B.Layout_Type, Global_Storage, Val); else pragma Assert (Get_Type_Staticness (Def) /= Locally); - Info.S.Static_Bounds := False; - Info.S.Composite_Bounds := Create_Var - (Create_Var_Identifier ("STB"), Base_Info.B.Bounds_Type); + Info.S.Composite_Layout := Create_Var + (Create_Var_Identifier ("STL"), Info.B.Layout_Type); if Elab_Now then - Elab_Composite_Subtype_Bounds (Def); + Elab_Composite_Subtype_Layout (Def); end if; end if; - end Create_Composite_Subtype_Bounds_Var; + end Create_Composite_Subtype_Layout_Var; ------------- -- Array -- @@ -793,25 +881,50 @@ package body Trans.Chap3 is end loop; if Is_Unbounded_Type (El_Info) then - -- Bounds and size for element. - New_Record_Field (Constr, Info.B.El_Bounds, - Get_Identifier ("el_bound"), El_Info.B.Bounds_Type); - New_Record_Field (Constr, Info.B.El_Size, Get_Identifier ("el_size"), - Ghdl_Sizes_Type); + -- Add layout for the element. + New_Record_Field + (Constr, Info.B.Bounds_El, + Get_Identifier ("el_layout"), El_Info.B.Layout_Type); end if; Finish_Record_Type (Constr, Info.B.Bounds_Type); Finish_Unbounded_Type_Bounds (Info); end Translate_Array_Type_Bounds; + -- Create the layout type. + procedure Create_Array_Type_Layout_Type (Info : Type_Info_Acc) + is + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Info.B.Layout_Size, + Get_Identifier ("size"), Ghdl_Sizes_Type); + New_Record_Field (Constr, Info.B.Layout_Bounds, + Get_Identifier ("bounds"), Info.B.Bounds_Type); + Finish_Record_Type (Constr, Info.B.Layout_Type); + + New_Type_Decl (Create_Identifier ("LAYOUT"), Info.B.Layout_Type); + Info.B.Layout_Ptr_Type := New_Access_Type (Info.B.Layout_Type); + New_Type_Decl (Create_Identifier ("LAYOUTP"), Info.B.Layout_Ptr_Type); + end Create_Array_Type_Layout_Type; + procedure Translate_Array_Type_Base - (Def : Iir_Array_Type_Definition; - Info : Type_Info_Acc) + (Def : Iir_Array_Type_Definition; Info : Type_Info_Acc) is El_Type : constant Iir := Get_Element_Subtype (Def); El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); begin - if Is_Complex_Type (El_Tinfo) or else Is_Unbounded_Type (El_Tinfo) then + Info.B.Align := El_Tinfo.B.Align; + if Is_Static_Type (El_Tinfo) then + -- Simple case: the array is really an array. + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + Info.B.Base_Type (Kind) := + New_Array_Type (El_Tinfo.Ortho_Type (Kind), Ghdl_Index_Type); + end loop; + + -- Declare the types. + Finish_Unbounded_Type_Base (Info); + else if El_Tinfo.Type_Mode in Type_Mode_Arrays then Info.B.Base_Type := El_Tinfo.B.Base_Ptr_Type; Info.B.Base_Ptr_Type := El_Tinfo.B.Base_Ptr_Type; @@ -819,20 +932,13 @@ package body Trans.Chap3 is Info.B.Base_Type := El_Tinfo.Ortho_Ptr_Type; Info.B.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type; end if; - else - for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop - Info.B.Base_Type (Kind) := - New_Array_Type (El_Tinfo.Ortho_Type (Kind), Ghdl_Index_Type); - end loop; - Finish_Unbounded_Type_Base (Info); + pragma Assert (Info.B.Align /= Align_Undef); end if; end Translate_Array_Type_Base; - procedure Translate_Array_Type_Definition - (Def : Iir_Array_Type_Definition) + procedure Translate_Array_Type (Def : Iir_Array_Type_Definition) is Info : constant Type_Info_Acc := Get_Info (Def); - El_Tinfo : Type_Info_Acc; begin Info.Type_Mode := Type_Mode_Fat_Array; Info.B := Ortho_Info_Basetype_Array_Init; @@ -843,14 +949,10 @@ package body Trans.Chap3 is Create_Unbounded_Type_Fat_Pointer (Info); Finish_Type_Definition (Info, False); - El_Tinfo := Get_Info (Get_Element_Subtype (Def)); - if Is_Complex_Type (El_Tinfo) then - -- This is a complex type. - -- No size variable for unconstrained array type. - Set_Complex_Type (Info, El_Tinfo.C (Mode_Value).Builder_Need_Func); - end if; + Create_Array_Type_Layout_Type (Info); + Info.Type_Incomplete := False; - end Translate_Array_Type_Definition; + end Translate_Array_Type; -- Get the length of DEF, ie the number of elements. -- If the length is not statically defined, returns -1. @@ -942,7 +1044,7 @@ package body Trans.Chap3 is Info.Type_Locally_Constrained := (Len >= 0); Info.B := Pinfo.B; Info.S := Pinfo.S; - if Is_Complex_Type (Pinfo) + if Is_Complex_Type (Get_Info (Get_Element_Subtype (Parent_Type))) or else not Info.Type_Locally_Constrained then -- This is a complex type as the size is not known at compile @@ -950,18 +1052,6 @@ package body Trans.Chap3 is Info.Type_Mode := Type_Mode_Complex_Array; Info.Ortho_Type := Pinfo.B.Base_Ptr_Type; Info.Ortho_Ptr_Type := Pinfo.B.Base_Ptr_Type; - - -- If the base type need a builder, so does the subtype. - if Is_Complex_Type (Pinfo) - and then Pinfo.C (Mode_Value).Builder_Need_Func - then - Copy_Complex_Type (Info, Pinfo); - else - Set_Complex_Type (Info, False); - end if; - - -- Type is bounded, but not statically. - Create_Size_Var (Def, Info); else -- Length is known. Create a constrained array. El_Constrained := Get_Array_Element_Constraint (Def) /= Null_Iir; @@ -1007,88 +1097,53 @@ package body Trans.Chap3 is Info.Type_Mode := Type_Mode_Unbounded_Array; Create_Array_For_Array_Subtype (Def, Info.B.Base_Type, Info.B.Base_Ptr_Type); - - -- If the base type need a builder, so does the subtype. - if Is_Complex_Type (Pinfo) then - if Pinfo.C (Mode_Value).Builder_Need_Func then - Copy_Complex_Type (Info, Pinfo); - else - Set_Complex_Type (Info, False); - end if; - end if; end Translate_Array_Subtype_Definition_Constrained_Element; procedure Create_Array_Type_Builder (Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type) is + El_Type : constant Iir := Get_Element_Subtype (Def); + El_Info : constant Type_Info_Acc := Get_Info (El_Type); Info : constant Type_Info_Acc := Get_Info (Def); - Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; - Bound : constant O_Dnode := Info.C (Kind).Builder_Bound_Param; - Var_Off : O_Dnode; - Var_Mem : O_Dnode; - Var_Length : O_Dnode; - El_Type : Iir; - El_Info : Type_Info_Acc; - Label : O_Snode; - begin - Start_Subprogram_Body (Info.C (Kind).Builder_Func); - Subprgs.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); - - -- Compute length of the array. - New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, - Ghdl_Index_Type); - New_Var_Decl (Var_Mem, Get_Identifier ("mem"), O_Storage_Local, - Info.B.Base_Ptr_Type (Kind)); - New_Var_Decl (Var_Off, Get_Identifier ("off"), O_Storage_Local, - Ghdl_Index_Type); + Layout_Param : constant O_Dnode := + Info.B.Builder (Kind).Builder_Layout_Param; + Layout : Mnode; + El_Size : O_Enode; + Size : O_Enode; + begin + Start_Subprogram_Body (Info.B.Builder (Kind).Builder_Proc); + Subprgs.Start_Subprg_Instance_Use + (Info.B.Builder (Kind).Builder_Instance); + Open_Local_Temp; - El_Type := Get_Element_Subtype (Def); - El_Info := Get_Info (El_Type); + Layout := Dp2M (Layout_Param, Info, Kind, + Info.B.Layout_Type, Info.B.Layout_Ptr_Type); - New_Assign_Stmt - (New_Obj (Var_Length), - New_Dyadic_Op (ON_Mul_Ov, - New_Value (Get_Var (El_Info.C (Kind).Size_Var)), - Get_Bounds_Length (Dp2M (Bound, Info, - Mode_Value, - Info.B.Bounds_Type, - Info.B.Bounds_Ptr_Type), - Def))); - - -- Find the innermost non-array element. - while El_Info.Type_Mode = Type_Mode_Complex_Array loop - El_Type := Get_Element_Subtype (El_Type); - El_Info := Get_Info (El_Type); - end loop; + -- Call the builder to layout the element (only for unbounded elements) + if Is_Unbounded_Type (El_Info) then + Gen_Call_Type_Builder + (Array_Layout_To_Element_Layout (Layout, Def), El_Type, Kind); - -- Set each index of the array. - Init_Var (Var_Off); - Start_Loop_Stmt (Label); - Gen_Exit_When (Label, New_Compare_Op (ON_Eq, - New_Obj_Value (Var_Off), - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); + El_Size := New_Value + (Layout_To_Size (Array_Layout_To_Element_Layout (Layout, Def), + Kind)); + else + El_Size := Get_Subtype_Size (El_Type, Mnode_Null, Kind); + end if; - New_Assign_Stmt - (New_Obj (Var_Mem), - New_Unchecked_Address - (New_Slice (New_Access_Element - (New_Convert_Ov (New_Obj_Value (Base), - Char_Ptr_Type)), - Chararray_Type, - New_Obj_Value (Var_Off)), - Info.B.Base_Ptr_Type (Kind))); + -- Compute size. + Size := New_Dyadic_Op + (ON_Mul_Ov, + El_Size, + Get_Bounds_Length (Layout_To_Bounds (Layout), Def)); - New_Assign_Stmt - (New_Obj (Var_Off), - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Var_Off), - Gen_Call_Type_Builder (Dp2M (Var_Mem, El_Info, Kind), El_Type))); - Finish_Loop_Stmt (Label); + -- Set size. + New_Assign_Stmt (Layout_To_Size (Layout, Kind), Size); - New_Return_Stmt (New_Obj_Value (Var_Off)); + Close_Local_Temp; - Subprgs.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Subprgs.Finish_Subprg_Instance_Use + (Info.B.Builder (Kind).Builder_Instance); Finish_Subprogram_Body; end Create_Array_Type_Builder; @@ -1097,82 +1152,31 @@ package body Trans.Chap3 is -------------- -- Get the alignment mask for *ortho* type ATYPE. - function Get_Type_Alignmask (Atype : O_Tnode) return O_Enode is + function Get_Alignmask (Align : Alignment_Type) return O_Enode is begin - return New_Dyadic_Op - (ON_Sub_Ov, - New_Lit (New_Alignof (Atype, Ghdl_Index_Type)), - New_Lit (Ghdl_Index_1)); - end Get_Type_Alignmask; + return New_Dyadic_Op (ON_Sub_Ov, + New_Lit (Align_Val (Align)), + New_Lit (Ghdl_Index_1)); + end Get_Alignmask; -- Align VALUE (of unsigned type) for type ATYPE. -- The formulae is: (V + (A - 1)) and not (A - 1), where A is the -- alignment for ATYPE in bytes. - function Realign (Value : O_Enode; Atype : O_Tnode) return O_Enode is + function Realign (Value : O_Enode; Align : Alignment_Type) return O_Enode is begin return New_Dyadic_Op (ON_And, - New_Dyadic_Op (ON_Add_Ov, Value, Get_Type_Alignmask (Atype)), - New_Monadic_Op (ON_Not, Get_Type_Alignmask (Atype))); + New_Dyadic_Op (ON_Add_Ov, Value, Get_Alignmask (Align)), + New_Monadic_Op (ON_Not, Get_Alignmask (Align))); end Realign; function Realign (Value : O_Enode; Atype : Iir) return O_Enode is Tinfo : constant Type_Info_Acc := Get_Info (Atype); - Otype : O_Tnode; - begin - if Is_Unbounded_Type (Tinfo) then - Otype := Tinfo.B.Base_Type (Mode_Value); - else - Otype := Tinfo.Ortho_Type (Mode_Value); - end if; - return Realign (Value, Otype); - end Realign; - - function Realign (Value : O_Enode; Mask : O_Dnode) return O_Enode is begin - return New_Dyadic_Op - (ON_And, - New_Dyadic_Op (ON_Add_Ov, Value, New_Obj_Value (Mask)), - New_Monadic_Op (ON_Not, New_Obj_Value (Mask))); + return Realign (Value, Tinfo.B.Align); end Realign; - -- Find the innermost non-array element. - function Get_Innermost_Non_Array_Element (Atype : Iir) return Iir - is - Res : Iir := Atype; - begin - while Get_Kind (Res) in Iir_Kinds_Array_Type_Definition loop - Res := Get_Element_Subtype (Res); - end loop; - return Res; - end Get_Innermost_Non_Array_Element; - - -- Declare the bounds types for DEF. - procedure Translate_Record_Type_Bounds - (Def : Iir_Record_Type_Definition; Info : Type_Info_Acc) - is - List : constant Iir_Flist := Get_Elements_Declaration_List (Def); - El : Iir; - El_Tinfo : Type_Info_Acc; - El_Info : Field_Info_Acc; - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - El_Tinfo := Get_Info (Get_Type (El)); - if Is_Unbounded_Type (El_Tinfo) then - El_Info := Get_Info (El); - New_Record_Field (Constr, El_Info.Field_Bound, - Create_Identifier_Without_Prefix (El), - El_Tinfo.B.Bounds_Type); - end if; - end loop; - Finish_Record_Type (Constr, Info.B.Bounds_Type); - Finish_Unbounded_Type_Bounds (Info); - end Translate_Record_Type_Bounds; - procedure Translate_Record_Type (Def : Iir_Record_Type_Definition) is Info : constant Type_Info_Acc := Get_Info (Def); @@ -1184,32 +1188,37 @@ package body Trans.Chap3 is Field_Info : Ortho_Info_Acc; El_Type : Iir; El_Tinfo : Type_Info_Acc; - El_Tnode : O_Tnode; + Align : Alignment_Type; -- True if a size variable will be created since the size of -- the record is not known at compile-time. - Need_Size : Boolean; + Is_Complex : Boolean; Mark : Id_Mark_Type; begin - Need_Size := False; - -- First, translate the anonymous type of the elements. + Align := Align_8; for I in Flist_First .. Flist_Last (List) loop El := Get_Nth_Element (List, I); El_Type := Get_Type (El); - if Get_Info (El_Type) = null then + El_Tinfo := Get_Info (El_Type); + if El_Tinfo = null then Push_Identifier_Prefix (Mark, Get_Identifier (El)); Translate_Subtype_Indication (El_Type, True); Pop_Identifier_Prefix (Mark); + El_Tinfo := Get_Info (El_Type); end if; - Need_Size := Need_Size or else Is_Complex_Type (Get_Info (El_Type)); Field_Info := Add_Info (El, Kind_Field); + + pragma Assert (El_Tinfo.B.Align /= Align_Undef); + Align := Alignment_Type'Max (Align, El_Tinfo.B.Align); end loop; + Info.B.Align := Align; -- Then create the record type. Info.S := Ortho_Info_Subtype_Record_Init; Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + Is_Complex := False; for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop Start_Record_Type (El_List); for I in Flist_First .. Flist_Last (List) loop @@ -1219,31 +1228,65 @@ package body Trans.Chap3 is if Is_Complex_Type (El_Tinfo) or else Is_Unbounded_Type (El_Tinfo) then - -- Always use an offset for a complex type. - El_Tnode := Ghdl_Index_Type; + Is_Complex := True; else - El_Tnode := El_Tinfo.Ortho_Type (Kind); + New_Record_Field (El_List, Field_Info.Field_Node (Kind), + Create_Identifier_Without_Prefix (El), + El_Tinfo.Ortho_Type (Kind)); end if; - New_Record_Field (El_List, Field_Info.Field_Node (Kind), - Create_Identifier_Without_Prefix (El), - El_Tnode); end loop; Finish_Record_Type (El_List, Info.B.Base_Type (Kind)); end loop; + -- Create the bounds type + Info.B.Bounds_Type := O_Tnode_Null; + Start_Record_Type (El_List); + New_Record_Field (El_List, Info.B.Layout_Size, + Get_Identifier ("size"), Ghdl_Sizes_Type); + for I in Flist_First .. Flist_Last (List) loop + declare + El : constant Iir := Get_Nth_Element (List, I); + Field_Info : constant Field_Info_Acc := Get_Info (El); + El_Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (El)); + Unbounded_El : constant Boolean := Is_Unbounded_Type (El_Tinfo); + Complex_El : constant Boolean := Is_Complex_Type (El_Tinfo); + begin + if Unbounded_El or Complex_El then + -- Offset + New_Record_Field + (El_List, Field_Info.Field_Node (Mode_Value), + Create_Identifier_Without_Prefix (El, "_OFF"), + Ghdl_Index_Type); + if Get_Has_Signal_Flag (Def) then + New_Record_Field + (El_List, Field_Info.Field_Node (Mode_Signal), + Create_Identifier_Without_Prefix (El, "_SIGOFF"), + Ghdl_Index_Type); + end if; + end if; + if Unbounded_El then + New_Record_Field + (El_List, Field_Info.Field_Bound, + Create_Identifier_Without_Prefix (El, "_BND"), + El_Tinfo.B.Layout_Type); + end if; + end; + end loop; + Finish_Record_Type (El_List, Info.B.Bounds_Type); + Finish_Unbounded_Type_Bounds (Info); + + -- For records: layout == bounds. + Info.B.Layout_Type := Info.B.Bounds_Type; + Info.B.Layout_Ptr_Type := Info.B.Bounds_Ptr_Type; + if Is_Unbounded then Info.Type_Mode := Type_Mode_Unbounded_Record; Finish_Unbounded_Type_Base (Info); - Translate_Record_Type_Bounds (Def, Info); Create_Unbounded_Type_Fat_Pointer (Info); Finish_Type_Definition (Info); - - -- There are internal fields for unbounded records, so the objects - -- must be built. - Set_Complex_Type (Info, True); else - if Need_Size then + if Is_Complex then Info.Type_Mode := Type_Mode_Complex_Record; else Info.Type_Mode := Type_Mode_Static_Record; @@ -1252,10 +1295,7 @@ package body Trans.Chap3 is Finish_Type_Definition (Info); Info.B.Base_Ptr_Type := Info.Ortho_Ptr_Type; - if Need_Size then - Set_Complex_Type (Info, True); - Create_Size_Var (Def, Info); - end if; + Create_Composite_Subtype_Layout_Var (Def, False); end if; end Translate_Record_Type; @@ -1296,23 +1336,23 @@ package body Trans.Chap3 is for I in Flist_First .. Flist_Last (El_List) loop El := Get_Nth_Element (El_List, I); El_Type := Get_Type (El); - if Is_Fully_Constrained_Type (El) then - El_Btype := Get_Type (Get_Nth_Element (El_Tm_List, I)); - if not Is_Fully_Constrained_Type (El_Btype) then - Has_New_Constraints := True; - if Get_Type_Staticness (El_Type) = Locally then - Has_Boxed_Elements := True; - end if; - Push_Identifier_Prefix (Mark, Get_Identifier (El)); - Translate_Subtype_Definition (El_Type, El_Btype, With_Vars); - Pop_Identifier_Prefix (Mark); + El_Btype := Get_Type (Get_Nth_Element (El_Tm_List, I)); + if Is_Fully_Constrained_Type (El_Type) + and then not Is_Fully_Constrained_Type (El_Btype) + then + Has_New_Constraints := True; + if Get_Type_Staticness (El_Type) = Locally then + Has_Boxed_Elements := True; end if; + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + Translate_Subtype_Definition (El_Type, El_Btype, With_Vars); + Pop_Identifier_Prefix (Mark); end if; end loop; -- By default, use the same representation as the base type. Info.all := Base_Info.all; - Info.S := Ortho_Info_Subtype_Record_Init; + -- Info.S := Ortho_Info_Subtype_Record_Init; -- However, it is a different subtype which has its own rti. Info.Type_Rti := O_Dnode_Null; @@ -1323,6 +1363,15 @@ package body Trans.Chap3 is -- create objects, so wait until it is completly constrained. -- The subtype is simply an alias. -- In both cases, use the same representation as its type mark. + + for I in Flist_First .. Flist_Last (El_Blist) loop + B_El := Get_Nth_Element (El_Blist, I); + El := Get_Nth_Element (El_List, I); + if El /= B_El then + Set_Info (El, Get_Info (B_El)); + end if; + end loop; + return; end if; @@ -1333,9 +1382,6 @@ package body Trans.Chap3 is Info.Type_Mode := Type_Mode_Complex_Record; end if; - -- Base type is complex (unbounded record) - Copy_Complex_Type (Info, Base_Info); - -- Then create the record type, containing the base record and the -- fields. if Has_Boxed_Elements then @@ -1350,7 +1396,7 @@ package body Trans.Chap3 is -- This element has been locally constrained. if Is_Unbounded_Type (Get_Info (Get_Type (B_El))) - and then Get_Type_Staticness (Get_Type(El)) = Locally + and then Get_Type_Staticness (Get_Type (El)) = Locally then if Kind = Mode_Value then Field_Info := Add_Info (El, Kind_Field); @@ -1363,6 +1409,11 @@ package body Trans.Chap3 is New_Record_Field (Rec, Field_Info.Field_Node (Kind), Create_Identifier_Without_Prefix (El), El_Tnode); + Field_Info.Field_Bound := Get_Info (B_El).Field_Bound; + else + if Kind = Mode_Value and then El /= B_El then + Set_Info (El, Get_Info (B_El)); + end if; end if; end loop; Finish_Record_Type (Rec, Info.Ortho_Type (Kind)); @@ -1374,14 +1425,18 @@ package body Trans.Chap3 is -- time. Info.Ortho_Type := Base_Info.B.Base_Type; Info.Ortho_Ptr_Type := Base_Info.B.Base_Ptr_Type; - end if; - if Get_Type_Staticness (Def) /= Locally then - Create_Size_Var (Def, Info); + for I in Flist_First .. Flist_Last (El_Blist) loop + B_El := Get_Nth_Element (El_Blist, I); + El := Get_Nth_Element (El_List, I); + if El /= B_El then + Set_Info (El, Get_Info (B_El)); + end if; + end loop; end if; if With_Vars then - Create_Composite_Subtype_Bounds_Var (Def, False); + Create_Composite_Subtype_Layout_Var (Def, False); end if; end Translate_Record_Subtype; @@ -1389,20 +1444,20 @@ package body Trans.Chap3 is (Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type) is Info : constant Type_Info_Acc := Get_Info (Def); - Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; + Layout_Param : constant O_Dnode := + Info.B.Builder (Kind).Builder_Layout_Param; List : constant Iir_Flist := Get_Elements_Declaration_List (Def); - El : Iir_Element_Declaration; + Layout : Mnode; Off_Var : O_Dnode; Off_Val : O_Enode; - El_Off : O_Enode; - Sub_Bound : Mnode; - El_Type : Iir; - Inner_Type : Iir; - El_Tinfo : Type_Info_Acc; begin - Start_Subprogram_Body (Info.C (Kind).Builder_Func); - Subprgs.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Start_Subprogram_Body (Info.B.Builder (Kind).Builder_Proc); + Subprgs.Start_Subprg_Instance_Use + (Info.B.Builder (Kind).Builder_Instance); + + Layout := Dp2M (Layout_Param, Info, Kind, + Info.B.Layout_Type, Info.B.Layout_Ptr_Type); -- Declare OFF, the offset variable New_Var_Decl (Off_Var, Get_Identifier ("off"), O_Storage_Local, @@ -1410,93 +1465,58 @@ package body Trans.Chap3 is -- Reserve memory for the record, ie: -- OFF = SIZEOF (record). - -- Align for signals, as the base type may contain a single index. Off_Val := New_Lit (New_Sizeof (Info.B.Base_Type (Kind), Ghdl_Index_Type)); - if Kind = Mode_Signal then - Off_Val := Realign (Off_Val, Ghdl_Signal_Ptr); - end if; New_Assign_Stmt (New_Obj (Off_Var), Off_Val); -- Set memory for each complex element. for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - El_Type := Get_Type (El); - El_Tinfo := Get_Info (El_Type); - if Is_Complex_Type (El_Tinfo) - or else Is_Unbounded_Type (El_Tinfo) - then - -- Complex or unbounded type. Field is an offset. - - -- Align on the innermost array element (which should be - -- a record) for Mode_Value. No need to align for signals, - -- as all non-composite elements are accesses. - Inner_Type := Get_Innermost_Non_Array_Element (El_Type); - Off_Val := New_Obj_Value (Off_Var); - if Kind = Mode_Value then - Off_Val := Realign (Off_Val, Inner_Type); + declare + El : constant Iir := Get_Nth_Element (List, I); + El_Type : constant Iir := Get_Type (El); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + El_Complex : constant Boolean := Is_Complex_Type (El_Tinfo); + El_Unbounded : constant Boolean := Is_Unbounded_Type (El_Tinfo); + El_Layout : Mnode; + El_Size : O_Enode; + begin + if El_Unbounded then + -- Set layout + El_Layout := Record_Layout_To_Element_Layout (Layout, El); + Gen_Call_Type_Builder (El_Layout, El_Type, Kind); end if; - New_Assign_Stmt (New_Obj (Off_Var), Off_Val); - -- Set the offset. - New_Assign_Stmt - (New_Selected_Element (New_Acc_Value (New_Obj (Base)), - Get_Info (El).Field_Node (Kind)), - New_Obj_Value (Off_Var)); + if El_Unbounded or El_Complex then + -- Complex or unbounded type. Field is an offset. - Open_Temp; - - if Is_Complex_Type (El_Tinfo) - and then El_Tinfo.C (Kind).Builder_Need_Func - then - -- This type needs a builder, call it. - declare - Base2 : Mnode; - Ptr_Var : O_Dnode; - begin - if Is_Unbounded_Type (Info) then - Base2 := Create_Temp (Info, Kind); - New_Assign_Stmt - (M2Lp (Get_Composite_Bounds (Base2)), - New_Obj_Value (Info.C (Kind).Builder_Bound_Param)); - New_Assign_Stmt - (M2Lp (Get_Composite_Base (Base2)), - New_Obj_Value (Info.C (Kind).Builder_Base_Param)); - else - Base2 := Dp2M (Base, Info, Kind); - end if; - - Ptr_Var := Create_Temp (El_Tinfo.Ortho_Ptr_Type (Kind)); + -- Align on the innermost array element (which should be + -- a record) for Mode_Value. No need to align for signals, + -- as all non-composite elements are accesses. + Off_Val := New_Obj_Value (Off_Var); + if Kind = Mode_Value then + Off_Val := Realign (Off_Val, El_Type); + end if; + New_Assign_Stmt (New_Obj (Off_Var), Off_Val); - New_Assign_Stmt - (New_Obj (Ptr_Var), - M2E (Chap6.Translate_Selected_Element (Base2, El))); + -- Set the offset. + New_Assign_Stmt + (Record_Layout_To_Element_Offset (Layout, El, Kind), + New_Obj_Value (Off_Var)); - El_Off := Gen_Call_Type_Builder - (Dp2M (Ptr_Var, El_Tinfo, Kind), El_Type); - end; - else - if Is_Unbounded_Type (El_Tinfo) then - Sub_Bound := Bounds_To_Element_Bounds - (Dp2M (Info.C (Kind).Builder_Bound_Param, - Info, Mode_Value, - Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type), - El); + if El_Unbounded then + El_Layout := Record_Layout_To_Element_Layout (Layout, El); + El_Size := New_Value + (Sizes_To_Size (Layout_To_Sizes (El_Layout), Kind)); else - Sub_Bound := Mnode_Null; + El_Size := Get_Subtype_Size (El_Type, El_Layout, Kind); end if; - -- Allocate memory. - El_Off := Get_Subtype_Size (El_Type, Sub_Bound, Kind); + New_Assign_Stmt (New_Obj (Off_Var), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Off_Var), + El_Size)); end if; - - New_Assign_Stmt - (New_Obj (Off_Var), - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Off_Var), El_Off)); - - Close_Temp; - end if; + end; end loop; -- Align the size to the object alignment. @@ -1505,9 +1525,11 @@ package body Trans.Chap3 is Off_Val := Realign (Off_Val, Def); end if; - New_Return_Stmt (Off_Val); + -- Set size. + New_Assign_Stmt (Layout_To_Size (Layout, Kind), Off_Val); - Subprgs.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Subprgs.Finish_Subprg_Instance_Use + (Info.B.Builder (Kind).Builder_Instance); Finish_Subprogram_Body; end Create_Record_Type_Builder; @@ -1555,6 +1577,7 @@ package body Trans.Chap3 is -- Otherwise, it is a thin pointer. Def_Info.Type_Mode := Type_Mode_Acc; end if; + Def_Info.B.Align := Align_Ptr; if D_Info.Kind = Kind_Incomplete_Type then -- Incomplete access. @@ -1634,11 +1657,6 @@ package body Trans.Chap3 is Info.Type_Mode := Type_Mode_Protected; - -- A protected type is a complex type, as its size is not known - -- at definition point (will be known at body declaration). - Info.C := new Complex_Type_Arr_Info; - Info.C (Mode_Value).Builder_Need_Func := False; - -- This is just use to set overload number on subprograms, and to -- translate interfaces. Push_Identifier_Prefix @@ -1904,7 +1922,7 @@ package body Trans.Chap3 is return Create_Static_Scalar_Type_Range (Def); when Iir_Kind_Array_Subtype_Definition => - return Create_Static_Composite_Subtype_Bounds (Def); + return Create_Static_Array_Subtype_Bounds (Def); when Iir_Kind_Array_Type_Definition => return O_Cnode_Null; @@ -1930,7 +1948,7 @@ package body Trans.Chap3 is when Iir_Kind_Array_Subtype_Definition => if Get_Constraint_State (Def) = Fully_Constrained then - Elab_Composite_Subtype_Bounds (Def); + Elab_Composite_Subtype_Layout (Def); end if; when Iir_Kind_Array_Type_Definition => @@ -1948,16 +1966,16 @@ package body Trans.Chap3 is end; return; - when Iir_Kind_Record_Subtype_Definition => + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Record_Type_Definition => Info := Get_Info (Def); - if Info.S.Composite_Bounds /= Null_Var then - Elab_Composite_Subtype_Bounds (Def); + if Info.S.Composite_Layout /= Null_Var then + Elab_Composite_Subtype_Layout (Def); end if; when Iir_Kind_Access_Type_Definition | Iir_Kind_Access_Subtype_Definition | Iir_Kind_File_Type_Definition - | Iir_Kind_Record_Type_Definition | Iir_Kind_Protected_Type_Declaration => return; @@ -2111,118 +2129,6 @@ package body Trans.Chap3 is end if; end Create_Subtype_Info_From_Type; - procedure Elab_Type_Definition_Size_Var (Def : Iir); - - procedure Elab_Record_Size_Var (Def : Iir; Kind : Object_Kind_Type) - is - Info : constant Type_Info_Acc := Get_Info (Def); - List : constant Iir_Flist := Get_Elements_Declaration_List (Def); - El : Iir_Element_Declaration; - El_Type : Iir; - El_Tinfo : Type_Info_Acc; - Inner_Type : Iir; - Res : O_Enode; - Align_Var : O_Dnode; - begin - Open_Temp; - - -- Start with the size of the 'base' record, that - -- contains all non-complex types and an offset for - -- each complex types. - Res := New_Lit (New_Sizeof (Info.Ortho_Type (Kind), Ghdl_Index_Type)); - - -- Start with alignment of the record. - -- ALIGN = ALIGNOF (record) - case Kind is - when Mode_Value => - Align_Var := Create_Temp (Ghdl_Index_Type); - New_Assign_Stmt - (New_Obj (Align_Var), - Get_Type_Alignmask (Info.Ortho_Type (Kind))); - when Mode_Signal => - Res := Realign (Res, Ghdl_Signal_Ptr); - end case; - - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - El_Type := Get_Type (El); - El_Tinfo := Get_Info (El_Type); - if Get_Type_Staticness (El_Type) /= Locally - and then - (Is_Complex_Type (El_Tinfo) - or else Get_Kind (El) = Iir_Kind_Record_Element_Constraint) - then - Inner_Type := Get_Innermost_Non_Array_Element (El_Type); - - -- Align (only for Mode_Value) the size, - -- and add the size of the element. - if Kind = Mode_Value then - -- Largest alignment. - New_Assign_Stmt - (New_Obj (Align_Var), - New_Dyadic_Op - (ON_Or, - New_Obj_Value (Align_Var), - Get_Type_Alignmask - (Get_Ortho_Type (Inner_Type, Mode_Value)))); - Res := Realign (Res, Inner_Type); - end if; - - Res := New_Dyadic_Op - (ON_Add_Ov, - Res, New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var))); - end if; - end loop; - if Kind = Mode_Value then - Res := Realign (Res, Align_Var); - end if; - New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); - Close_Temp; - end Elab_Record_Size_Var; - - procedure Elab_Array_Size_Var (Def : Iir; Kind : Object_Kind_Type) - is - Info : constant Type_Info_Acc := Get_Info (Def); - El_Type : constant Iir := Get_Element_Subtype (Def); - Res : O_Enode; - begin - Res := New_Dyadic_Op - (ON_Mul_Ov, - Get_Array_Type_Length (Def), - Chap3.Get_Object_Size (T2M (El_Type, Kind), El_Type)); - New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); - end Elab_Array_Size_Var; - - procedure Elab_Type_Definition_Size_Var (Def : Iir) - is - Info : constant Type_Info_Acc := Get_Info (Def); - begin - if not Is_Complex_Type (Info) then - return; - end if; - - for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop - if Info.C (Kind).Size_Var /= Null_Var then - case Info.Type_Mode is - when Type_Mode_Non_Composite - | Type_Mode_Unbounded_Array - | Type_Mode_Unbounded_Record - | Type_Mode_Unknown - | Type_Mode_Protected => - raise Internal_Error; - when Type_Mode_Static_Record - | Type_Mode_Static_Array => - -- No need to create a size var, the size is known. - raise Internal_Error; - when Type_Mode_Complex_Record => - Elab_Record_Size_Var (Def, Kind); - when Type_Mode_Complex_Array => - Elab_Array_Size_Var (Def, Kind); - end case; - end if; - end loop; - end Elab_Type_Definition_Size_Var; - procedure Create_Type_Range_Var (Def : Iir) is Info : constant Type_Info_Acc := Get_Info (Def); @@ -2388,7 +2294,7 @@ package body Trans.Chap3 is when Iir_Kind_Array_Type_Definition => Translate_Array_Element_Definition (Def); - Translate_Array_Type_Definition (Def); + Translate_Array_Type (Def); when Iir_Kind_Record_Type_Definition => Info.B := Ortho_Info_Basetype_Record_Init; @@ -2480,13 +2386,13 @@ package body Trans.Chap3 is end if; when Iir_Kind_Array_Subtype_Definition => - -- Handle element subtype. declare El_Type : constant Iir := Get_Element_Subtype (Def); Parent_El_Type : constant Iir := Get_Element_Subtype (Parent_Type); Mark : Id_Mark_Type; begin + -- Handle element subtype. if El_Type /= Parent_El_Type then Push_Identifier_Prefix (Mark, "ET"); Translate_Subtype_Definition @@ -2497,7 +2403,7 @@ package body Trans.Chap3 is if Get_Constraint_State (Def) = Fully_Constrained then Translate_Array_Subtype_Definition (Def, Parent_Type); if With_Vars then - Create_Composite_Subtype_Bounds_Var (Def, False); + Create_Composite_Subtype_Layout_Var (Def, False); end if; elsif Is_Fully_Constrained_Type (El_Type) and then not Is_Fully_Constrained_Type (Parent_El_Type) @@ -2563,20 +2469,26 @@ package body Trans.Chap3 is raise Internal_Error; end case; + -- Create builder for arrays and non-static records Tinfo := Get_Info (Def); - if not Is_Complex_Type (Tinfo) - or else Tinfo.C (Mode_Value).Builder_Need_Func = False - then - return; - end if; + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Unbounded_Record + | Type_Mode_Complex_Record => + null; + when Type_Mode_Static_Record => + return; + when others => + -- Must have been filtered out above. + raise Internal_Error; + end case; if Kind in Subprg_Translate_Spec then -- Declare subprograms. Id := Get_Identifier (Decl); - Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value); - if Get_Has_Signal_Flag (Def) then - Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal); - end if; + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + Create_Builder_Subprogram_Decl (Tinfo, Id, Kind); + end loop; end if; if Kind in Subprg_Translate_Body then @@ -2587,15 +2499,13 @@ package body Trans.Chap3 is -- Define subprograms. case Get_Kind (Def) is when Iir_Kind_Array_Type_Definition => - Create_Array_Type_Builder (Def, Mode_Value); - if Get_Has_Signal_Flag (Def) then - Create_Array_Type_Builder (Def, Mode_Signal); - end if; + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + Create_Array_Type_Builder (Def, Kind); + end loop; when Iir_Kind_Record_Type_Definition => - Create_Record_Type_Builder (Def, Mode_Value); - if Get_Has_Signal_Flag (Def) then - Create_Record_Type_Builder (Def, Mode_Signal); - end if; + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + Create_Record_Type_Builder (Def, Kind); + end loop; when others => Error_Kind ("translate_type_subprograms", Def); end case; @@ -2636,7 +2546,6 @@ package body Trans.Chap3 is Elab_Type_Definition_Depend (Def); Elab_Type_Definition_Type_Range (Def); - Elab_Type_Definition_Size_Var (Def); end Elab_Type_Definition; procedure Translate_Subtype_Indication (Def : Iir; With_Vars : Boolean) @@ -2753,48 +2662,23 @@ package body Trans.Chap3 is Iinfo.B.Range_Type, Iinfo.B.Range_Ptr_Type); end Bounds_To_Range; - function Bounds_To_Element_Bounds (B : Mnode; El : Iir) return Mnode - is - El_Type : constant Iir := Get_Type (El); - El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); - Base_El : constant Iir := Get_Base_Element_Declaration (El); + function Record_Bounds_To_Element_Bounds (B : Mnode; El : Iir) + return Mnode is begin - return Lv2M - (New_Selected_Element (M2Lv (B), - Get_Info (Base_El).Field_Bound), - El_Tinfo, Mode_Value, - El_Tinfo.B.Bounds_Type, El_Tinfo.B.Bounds_Ptr_Type); - end Bounds_To_Element_Bounds; + return Layout_To_Bounds (Record_Layout_To_Element_Layout (B, El)); + end Record_Bounds_To_Element_Bounds; function Array_Bounds_To_Element_Bounds (B : Mnode; Atype : Iir) - return Mnode - is - Arr_Tinfo : constant Type_Info_Acc := Get_Info (Atype); - El_Type : constant Iir := Get_Element_Subtype (Atype); - El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + return Mnode is begin - return Lv2M - (New_Selected_Element (M2Lv (B), Arr_Tinfo.B.El_Bounds), - El_Tinfo, Mode_Value, - El_Tinfo.B.Bounds_Type, El_Tinfo.B.Bounds_Ptr_Type); + return Layout_To_Bounds (Array_Bounds_To_Element_Layout (B, Atype)); end Array_Bounds_To_Element_Bounds; function Array_Bounds_To_Element_Size (B : Mnode; Atype : Iir) - return O_Lnode - is - Arr_Tinfo : constant Type_Info_Acc := Get_Info (Atype); - Sizes : O_Lnode; - Field : O_Fnode; + return O_Lnode is begin - Sizes := New_Selected_Element (M2Lv (B), Arr_Tinfo.B.El_Size); - case Get_Object_Kind (B) is - when Mode_Value => - Field := Ghdl_Sizes_Val; - when Mode_Signal => - Field := Ghdl_Sizes_Sig; - end case; - Sizes := New_Selected_Element (Sizes, Field); - return Sizes; + return Layout_To_Size + (Array_Bounds_To_Element_Layout (B, Atype), Get_Object_Kind (B)); end Array_Bounds_To_Element_Size; function Type_To_Range (Atype : Iir) return Mnode @@ -2847,51 +2731,35 @@ package body Trans.Chap3 is Mode_Value); end Range_To_Right; - function Get_Array_Type_Bounds (Info : Type_Info_Acc) return Mnode - is + function Get_Composite_Type_Bounds (Atype : Iir) return Mnode is begin - case Info.Type_Mode is - when Type_Mode_Unbounded => - raise Internal_Error; - when Type_Mode_Bounded_Arrays - | Type_Mode_Bounded_Records => - return Varv2M (Info.S.Composite_Bounds, - Info, Mode_Value, - Info.B.Bounds_Type, - Info.B.Bounds_Ptr_Type); - when others => - raise Internal_Error; - end case; - end Get_Array_Type_Bounds; + return Layout_To_Bounds (Get_Composite_Type_Layout (Get_Info (Atype))); + end Get_Composite_Type_Bounds; - function Get_Array_Type_Bounds (Atype : Iir) return Mnode is - begin - return Get_Array_Type_Bounds (Get_Info (Atype)); - end Get_Array_Type_Bounds; - - function Get_Composite_Bounds (Arr : Mnode) return Mnode + function Get_Composite_Bounds (Obj : Mnode) return Mnode is - Info : constant Type_Info_Acc := Get_Type_Info (Arr); + Info : constant Type_Info_Acc := Get_Type_Info (Obj); begin case Info.Type_Mode is when Type_Mode_Unbounded_Array | Type_Mode_Unbounded_Record => declare - Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); + Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); begin return Lp2M - (New_Selected_Element (M2Lv (Arr), + (New_Selected_Element (M2Lv (Obj), Info.B.Bounds_Field (Kind)), Info, Mode_Value, Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type); end; - when Type_Mode_Bounded_Arrays - | Type_Mode_Bounded_Records => - return Get_Array_Type_Bounds (Info); + when Type_Mode_Bounded_Arrays => + return Layout_To_Bounds (Get_Composite_Type_Layout (Info)); + when Type_Mode_Bounded_Records => + return Get_Composite_Type_Layout (Info); when Type_Mode_Bounds_Acc => - return Lp2M (M2Lv (Arr), Info, Mode_Value); + return Lp2M (M2Lv (Obj), Info, Mode_Value); when others => raise Internal_Error; end case; @@ -2942,7 +2810,7 @@ package body Trans.Chap3 is if Type_Info.Type_Locally_Constrained then return New_Lit (Get_Thin_Array_Length (Atype)); else - return Get_Bounds_Length (Get_Array_Type_Bounds (Atype), Atype); + return Get_Bounds_Length (Get_Composite_Type_Bounds (Atype), Atype); end if; end Get_Array_Type_Length; @@ -2957,59 +2825,71 @@ package body Trans.Chap3 is end if; end Get_Array_Length; - function Get_Composite_Base (Arr : Mnode) return Mnode + -- Get the base part of a dope vector. + function Get_Unbounded_Base (Arr : Mnode) return Mnode is Info : constant Type_Info_Acc := Get_Type_Info (Arr); + Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); + begin + pragma Assert (Info.Type_Mode in Type_Mode_Unbounded); + return Lp2M + (New_Selected_Element (M2Lv (Arr), Info.B.Base_Field (Kind)), + Info, Kind, + Info.B.Base_Type (Kind), Info.B.Base_Ptr_Type (Kind)); + end Get_Unbounded_Base; + + function Get_Composite_Base (Obj : Mnode) return Mnode + is + Info : constant Type_Info_Acc := Get_Type_Info (Obj); begin case Info.Type_Mode is when Type_Mode_Unbounded_Array | Type_Mode_Unbounded_Record => - declare - Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); - begin - return Lp2M - (New_Selected_Element (M2Lv (Arr), - Info.B.Base_Field (Kind)), - Info, Kind, - Info.B.Base_Type (Kind), Info.B.Base_Ptr_Type (Kind)); - end; - when Type_Mode_Bounded_Arrays => - return Arr; - when Type_Mode_Bounded_Records => - return Unbox_Record (Arr); + return Get_Unbounded_Base (Obj); + when Type_Mode_Bounded_Arrays + | Type_Mode_Bounded_Records => + return Obj; when others => raise Internal_Error; end case; end Get_Composite_Base; - function Unbox_Record (Arr : Mnode) return Mnode + function Unbox_Record (Obj : Mnode) return Mnode is - Info : constant Type_Info_Acc := Get_Type_Info (Arr); + Info : constant Type_Info_Acc := Get_Type_Info (Obj); + pragma Assert (Info.Type_Mode in Type_Mode_Bounded_Records); + Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); + Box_Field : constant O_Fnode := Info.S.Box_Field (Kind); + begin + if Box_Field /= O_Fnode_Null then + -- Unbox the record. + return Lv2M (New_Selected_Element (M2Lv (Obj), Box_Field), + Info, Kind, + Info.B.Base_Type (Kind), + Info.B.Base_Ptr_Type (Kind)); + else + return Obj; + end if; + end Unbox_Record; + + function Get_Composite_Unbounded_Base (Obj : Mnode) return Mnode + is + Info : constant Type_Info_Acc := Get_Type_Info (Obj); begin case Info.Type_Mode is - when Type_Mode_Arrays => - return Arr; - when Type_Mode_Unbounded_Record => - return Arr; + when Type_Mode_Unbounded_Array + | Type_Mode_Unbounded_Record => + return Get_Unbounded_Base (Obj); + when Type_Mode_Bounded_Arrays => + -- This works in ortho as an access to unconstrained array is + -- also an access to a constrained array. + return Obj; when Type_Mode_Bounded_Records => - declare - Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); - Box_Field : constant O_Fnode := Info.S.Box_Field (Kind); - begin - if Box_Field /= O_Fnode_Null then - -- Unbox the record. - return Lv2M (New_Selected_Element (M2Lv (Arr), Box_Field), - Info, Kind, - Info.B.Base_Type (Kind), - Info.B.Base_Ptr_Type (Kind)); - else - return Arr; - end if; - end; + return Unbox_Record (Obj); when others => raise Internal_Error; end case; - end Unbox_Record; + end Get_Composite_Unbounded_Base; function Create_Maybe_Fat_Array_Element (Arr : Mnode; Arr_Type : Iir) return Mnode @@ -3072,13 +2952,12 @@ package body Trans.Chap3 is return Mnode is El_Type : constant Iir := Get_Element_Subtype (Atype); - El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); Kind : constant Object_Kind_Type := Get_Object_Kind (Base); begin return E2M (Reindex_Array (Base, Atype, Index, - New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var))), + Get_Subtype_Size (El_Type, Mnode_Null, Kind)), Res_Info, Kind); end Reindex_Complex_Array; @@ -3151,22 +3030,6 @@ package body Trans.Chap3 is end if; end Slice_Base; - procedure Maybe_Call_Type_Builder (Obj : Mnode; Obj_Type : Iir) - is - Dinfo : constant Type_Info_Acc := - Get_Info (Get_Base_Type (Obj_Type)); - Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); - begin - if Is_Complex_Type (Dinfo) - and then Dinfo.C (Kind).Builder_Need_Func - then - Open_Temp; - -- Build the type. - Chap3.Gen_Call_Type_Builder (Obj, Obj_Type); - Close_Temp; - end if; - end Maybe_Call_Type_Builder; - procedure Allocate_Unbounded_Composite_Base (Alloc_Kind : Allocation_Kind; Res : Mnode; Arr_Type : Iir) @@ -3182,8 +3045,6 @@ package body Trans.Chap3 is New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Base (Res)), Gen_Alloc (Alloc_Kind, Length, Dinfo.B.Base_Ptr_Type (Kind))); - - Maybe_Call_Type_Builder (Res, Arr_Type); end Allocate_Unbounded_Composite_Base; procedure Allocate_Unbounded_Composite_Bounds @@ -3207,12 +3068,12 @@ package body Trans.Chap3 is begin Chap3.Translate_Subtype_Definition (Arr_Type, Get_Base_Type (Arr_Type), False); - Chap3.Create_Composite_Subtype_Bounds_Var (Arr_Type, False); + Chap3.Create_Composite_Subtype_Layout_Var (Arr_Type, False); end Translate_Array_Subtype; procedure Elab_Array_Subtype (Arr_Type : Iir) is begin - Chap3.Elab_Composite_Subtype_Bounds (Arr_Type); + Chap3.Elab_Composite_Subtype_Layout (Arr_Type); end Elab_Array_Subtype; procedure Create_Array_Subtype (Sub_Type : Iir) @@ -3226,8 +3087,7 @@ package body Trans.Chap3 is (Sub_Type, Get_Base_Type (Sub_Type), False); end if; -- Force creation of variables. - Chap3.Create_Composite_Subtype_Bounds_Var (Sub_Type, True); - Chap3.Elab_Type_Definition_Size_Var (Sub_Type); + Chap3.Create_Composite_Subtype_Layout_Var (Sub_Type, True); Pop_Identifier_Prefix (Mark); end Create_Array_Subtype; @@ -3271,66 +3131,30 @@ package body Trans.Chap3 is Type_Info : constant Type_Info_Acc := Get_Info (Atype); begin case Type_Info.Type_Mode is - when Type_Mode_Complex_Array - | Type_Mode_Complex_Record => - -- The length is pre-computed for a complex bounded type. - if Type_Info.C (Kind).Size_Var /= Null_Var then - return New_Value (Get_Var (Type_Info.C (Kind).Size_Var)); - else - raise Internal_Error; - end if; when Type_Mode_Non_Composite | Type_Mode_Static_Array | Type_Mode_Static_Record => return New_Lit (New_Sizeof (Type_Info.Ortho_Type (Kind), Ghdl_Index_Type)); + when Type_Mode_Complex_Array + | Type_Mode_Complex_Record => + -- The length is pre-computed for a complex bounded type. + return New_Value + (Sizes_To_Size + (Layout_To_Sizes + (Get_Composite_Type_Layout (Type_Info)), Kind)); when Type_Mode_Unbounded_Array => declare El_Type : constant Iir := Get_Element_Subtype (Atype); El_Sz : O_Enode; begin - -- See create_array_size_var. + -- FIXME: unbounded elements ? El_Sz := Get_Subtype_Size (El_Type, Mnode_Null, Kind); return New_Dyadic_Op (ON_Mul_Ov, Chap3.Get_Bounds_Length (Bounds, Atype), El_Sz); end; when Type_Mode_Unbounded_Record => - declare - El_List : constant Iir_Flist := - Get_Elements_Declaration_List (Atype); - El : Iir; - El_Type : Iir; - El_Type_Info : Type_Info_Acc; - El_Bounds : Mnode; - Stable_Bounds : Mnode; - Res : O_Enode; - begin - Stable_Bounds := Stabilize (Bounds); - - -- Size of base type - Res := New_Lit (New_Sizeof (Type_Info.B.Base_Type (Kind), - Ghdl_Index_Type)); - for I in Flist_First .. Flist_Last (El_List) loop - El := Get_Nth_Element (El_List, I); - El_Type := Get_Type (El); - El_Type_Info := Get_Info (El_Type); - if El_Type_Info.Type_Mode in Type_Mode_Unbounded then - -- Recurse - Res := Realign (Res, El_Type); - El_Bounds := Bounds_To_Element_Bounds (Stable_Bounds, El); - Res := New_Dyadic_Op - (ON_Add_Ov, - Res, Get_Subtype_Size (El_Type, El_Bounds, Kind)); - elsif Is_Complex_Type (El_Type_Info) then - -- Add supplement - Res := Realign (Res, El_Type); - Res := New_Dyadic_Op - (ON_Add_Ov, - Res, Get_Subtype_Size (El_Type, Mnode_Null, Kind)); - end if; - end loop; - return Res; - end; + return New_Value (Sizes_To_Size (Layout_To_Sizes (Bounds), Kind)); when others => raise Internal_Error; end case; @@ -3385,8 +3209,6 @@ package body Trans.Chap3 is Gen_Alloc (Alloc_Kind, Chap3.Get_Object_Size (T2M (Obj_Type, Kind), Obj_Type), Tinfo.Ortho_Ptr_Type (Kind))); - - Maybe_Call_Type_Builder (Res, Obj_Type); end if; end Translate_Object_Allocation; diff --git a/src/vhdl/translate/trans-chap3.ads b/src/vhdl/translate/trans-chap3.ads index 9900f48a9..2b9f37e6b 100644 --- a/src/vhdl/translate/trans-chap3.ads +++ b/src/vhdl/translate/trans-chap3.ads @@ -43,7 +43,7 @@ package Trans.Chap3 is procedure Translate_Type_Subprograms (Decl : Iir; Kind : Subprg_Translate_Kind); - function Create_Static_Composite_Subtype_Bounds (Def : Iir) return O_Cnode; + function Create_Static_Composite_Subtype_Layout (Def : Iir) return O_Cnode; -- Same as Translate_type_definition only for std.standard.boolean and -- std.standard.bit. @@ -116,9 +116,6 @@ package Trans.Chap3 is -- For a second or third order complex type, INFO.C.BUILDER_NEED_FUNC -- is set to TRUE. - -- Call builder for variable pointed VAR of type VAR_TYPE. - procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir); - -- Functions for fat array. -- Fat array are array whose size is not known at compilation time. -- This corresponds to an unconstrained array or a non locally static @@ -166,11 +163,17 @@ package Trans.Chap3 is -- Get the number of elements in array ATYPE. function Get_Array_Type_Length (Atype : Iir) return O_Enode; - -- Get the base of array or record ARR. - function Get_Composite_Base (Arr : Mnode) return Mnode; + -- Get the base of array or record OBJ. If OBJ is already constrained, + -- return it. + function Get_Composite_Base (Obj : Mnode) return Mnode; + + -- Get the base of array or record OBJ; but if OBJ is already constrained, + -- convert it to the base of an unbounded object (so this unboxes the + -- records). + function Get_Composite_Unbounded_Base (Obj : Mnode) return Mnode; -- Get the bounds of composite ARR (an array or an unbounded record). - function Get_Composite_Bounds (Arr : Mnode) return Mnode; + function Get_Composite_Bounds (Obj : Mnode) return Mnode; -- Get the range ot ATYPE. function Type_To_Range (Atype : Iir) return Mnode; @@ -194,16 +197,27 @@ package Trans.Chap3 is function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) return Mnode; - -- Get array bounds for type ATYPE. - function Get_Array_Type_Bounds (Atype : Iir) return Mnode; + -- Get array/record bounds for type ATYPE. + function Get_Composite_Type_Bounds (Atype : Iir) return Mnode; -- Return a pointer to the base from bounds_acc ACC. function Get_Bounds_Acc_Base (Acc : O_Enode; D_Type : Iir) return O_Enode; + -- Return bounds from layout B. + function Layout_To_Bounds (B : Mnode) return Mnode; + + -- From a record layout B, return the layout of element EL. EL must be + -- an unbounded element. + function Record_Layout_To_Element_Layout (B : Mnode; El : Iir) return Mnode; + -- From an unbounded record bounds B, get the bounds for (unbounded) -- element EL. - function Bounds_To_Element_Bounds (B : Mnode; El : Iir) return Mnode; + function Record_Bounds_To_Element_Bounds (B : Mnode; El : Iir) return Mnode; + + -- Return the offset for field EL in record B. + function Record_Layout_To_Element_Offset + (B : Mnode; El : Iir; Kind : Object_Kind_Type) return O_Lnode; -- From an unbounded array bounds B, get the bounds for the (unbounded) -- element. @@ -246,9 +260,6 @@ package Trans.Chap3 is -- it may be the result of T2M. function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode; - -- If needed call the procedure to build OBJ. - procedure Maybe_Call_Type_Builder (Obj : Mnode; Obj_Type : Iir); - -- Allocate the base of an unbounded composite, whose length is -- determined from the bounds (already set). -- RES_PTR is a pointer to the fat pointer (must be a stable variable: it diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb index 47b9f5674..69577161e 100644 --- a/src/vhdl/translate/trans-chap4.adb +++ b/src/vhdl/translate/trans-chap4.adb @@ -301,8 +301,6 @@ package body Trans.Chap4 is is Type_Info : constant Type_Info_Acc := Get_Type_Info (Var); Kind : constant Object_Kind_Type := Get_Object_Kind (Var); - Targ : Mnode; - Has_Ref : Boolean; begin -- Cannot allocate unconstrained object (since size is unknown). pragma Assert (Type_Info.Type_Mode not in Type_Mode_Unbounded); @@ -312,34 +310,12 @@ package body Trans.Chap4 is return; end if; - Has_Ref := False; - Targ := Var; - - if not Is_Static_Type (Type_Info) then - if Type_Info.C (Kind).Builder_Need_Func - and then not Is_Stable (Var) - then - -- Need a stable reference... - Targ := Create_Temp (Type_Info, Kind); - Has_Ref := True; - end if; - - -- Allocate variable. - New_Assign_Stmt (M2Lp (Targ), - Gen_Alloc (Alloc_Kind, - Chap3.Get_Object_Size (Var, Obj_Type), - Type_Info.Ortho_Ptr_Type (Kind))); - end if; - - if Type_Info.C (Kind).Builder_Need_Func then - -- Build the type. - Chap3.Gen_Call_Type_Builder (Targ, Obj_Type); - end if; - - if Has_Ref then - New_Assign_Stmt (M2Lp (Var), M2Addr (Targ)); - Var := Targ; - 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. @@ -535,13 +511,13 @@ package body Trans.Chap4 is -- Short-cut: don't allocate bounds. New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Name_Node)), - M2Addr (Chap3.Get_Array_Type_Bounds (Aggr_Type))); + M2Addr (Chap3.Get_Composite_Type_Bounds (Aggr_Type))); Chap3.Allocate_Unbounded_Composite_Base (Alloc_Kind, Name_Node, Get_Base_Type (Aggr_Type)); else Chap3.Translate_Object_Allocation (Name_Node, Alloc_Kind, Get_Base_Type (Aggr_Type), - Chap3.Get_Array_Type_Bounds (Aggr_Type)); + Chap3.Get_Composite_Type_Bounds (Aggr_Type)); end if; end; else @@ -642,23 +618,35 @@ package body Trans.Chap4 is Obj_Type : constant Iir := Get_Type (Obj); Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type); begin - if Type_Info.Type_Mode in Type_Mode_Unbounded then - 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)))); + 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 (Chap3.Get_Composite_Base (V)))); - Close_Temp; - end; - elsif Is_Complex_Type (Type_Info) then - Chap3.Gen_Deallocate - (New_Value (M2Lp (Chap6.Translate_Name (Obj, Mode_Value)))); - end if; + (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 @@ -1152,9 +1140,9 @@ package body Trans.Chap4 is begin Start_Association (Assoc, Ghdl_Signal_Name_Rti); New_Association - (Assoc, New_Lit (New_Global_Unchecked_Address - (Get_Info (Base_Decl).Signal_Rti, - Rtis.Ghdl_Rti_Access))); + (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; @@ -3184,7 +3172,8 @@ package body Trans.Chap4 is Start_Init_Value (C); Start_Record_Aggr (Constr, Ghdl_Location_Type_Node); New_Record_Aggr_El - (Constr, New_Global_Address (Current_Filename_Node, Char_Ptr_Type)); + (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, diff --git a/src/vhdl/translate/trans-chap5.adb b/src/vhdl/translate/trans-chap5.adb index 5f8375760..4c3f0ce20 100644 --- a/src/vhdl/translate/trans-chap5.adb +++ b/src/vhdl/translate/trans-chap5.adb @@ -424,7 +424,7 @@ package body Trans.Chap5 is if Get_Info (Formal_Type).Type_Mode in Type_Mode_Composite then New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Base (Formal_Val)), - M2Addr (Chap3.Get_Composite_Base (Actual_Val))); + M2Addr (Chap3.Get_Composite_Unbounded_Base (Actual_Val))); else New_Assign_Stmt (M2Lp (Formal_Val), M2Addr (Actual_Val)); end if; @@ -537,11 +537,11 @@ package body Trans.Chap5 is begin if Is_Fully_Constrained_Type (Actual_Type) then Chap3.Create_Array_Subtype (Actual_Type); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Bounds := Chap3.Get_Composite_Type_Bounds (Actual_Type); Tinfo := Get_Info (Actual_Type); if Save and then - Get_Alloc_Kind_For_Var (Tinfo.S.Composite_Bounds) = Alloc_Stack + Get_Alloc_Kind_For_Var (Tinfo.S.Composite_Layout) = Alloc_Stack then -- We need a copy. Bounds_Copy := Alloc_Bounds (Actual_Type, Alloc_System); @@ -575,7 +575,7 @@ package body Trans.Chap5 is In_Conv_Type := Get_Type (In_Conv); if Is_Fully_Constrained_Type (In_Conv_Type) then -- The 'in' conversion gives the type. - return Chap3.Get_Array_Type_Bounds (In_Conv_Type); + return Chap3.Get_Composite_Type_Bounds (In_Conv_Type); elsif Get_Kind (In_Conv) = Iir_Kind_Type_Conversion then -- Convert bounds of the actual. Can_Convert := True; @@ -590,7 +590,7 @@ package body Trans.Chap5 is Param_Type := Get_Type (Get_Interface_Declaration_Chain (Get_Implementation (Out_Conv))); if Is_Fully_Constrained_Type (Param_Type) then - return Chap3.Get_Array_Type_Bounds (Param_Type); + return Chap3.Get_Composite_Type_Bounds (Param_Type); else pragma Assert (Can_Convert); null; @@ -629,35 +629,33 @@ package body Trans.Chap5 is Get_Type (Get_Default_Value (Port)); begin Chap3.Create_Array_Subtype (Actual_Type); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Bounds := Chap3.Get_Composite_Type_Bounds (Actual_Type); end; when Iir_Kind_Association_Element_By_Individual => declare Actual_Type : constant Iir := Get_Actual_Type (Assoc); begin Chap3.Create_Array_Subtype (Actual_Type); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Bounds := Chap3.Get_Composite_Type_Bounds (Actual_Type); end; end case; Stabilize (Bounds); for K in Object_Kind_Type loop Act_Node := Chap6.Translate_Name (Port, K); - New_Assign_Stmt - (-- Note: this works only because it is not stabilized, and - -- therefore the bounds field is returned and not a pointer to - -- the bounds. - M2Lp (Chap3.Get_Composite_Bounds (Act_Node)), - M2Addr (Bounds)); + -- Note: this works only because it is not stabilized, and + -- therefore the bounds field is returned and not a pointer to + -- the bounds. + New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Act_Node)), + M2Addr (Bounds)); end loop; -- Set bounds of init value (if present) Info := Get_Info (Port); if Info.Signal_Val /= Null_Var then - New_Assign_Stmt - (M2Lp (Chap3.Get_Composite_Bounds - (Chap6.Get_Port_Init_Value (Port))), - M2Addr (Bounds)); + New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds + (Chap6.Get_Port_Init_Value (Port))), + M2Addr (Bounds)); end if; Close_Temp; end Elab_Unconstrained_Port_Bounds; @@ -824,7 +822,7 @@ package body Trans.Chap5 is (Formal_Type, Alloc_System, Formal_Node); else Chap3.Create_Array_Subtype (Obj_Type); - Bounds := Chap3.Get_Array_Type_Bounds (Obj_Type); + Bounds := Chap3.Get_Composite_Type_Bounds (Obj_Type); Chap3.Translate_Object_Allocation (Formal_Node, Alloc_System, Formal_Type, Bounds); end if; diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb index 08f7de26e..7eb74820a 100644 --- a/src/vhdl/translate/trans-chap6.adb +++ b/src/vhdl/translate/trans-chap6.adb @@ -412,7 +412,7 @@ package body Trans.Chap6 is -- Manually extract range since there is no infos for -- index subtype. Range_Ptr := Chap3.Bounds_To_Range - (Chap3.Get_Array_Type_Bounds (Prefix_Type), + (Chap3.Get_Composite_Type_Bounds (Prefix_Type), Prefix_Type, Dim); Stabilize (Range_Ptr); R := Translate_Index_To_Offset @@ -596,7 +596,7 @@ package body Trans.Chap6 is -- Save slice bounds. Slice_Range := Stabilize - (Chap3.Bounds_To_Range (Chap3.Get_Array_Type_Bounds (Slice_Type), + (Chap3.Bounds_To_Range (Chap3.Get_Composite_Type_Bounds (Slice_Type), Slice_Type, 1)); -- TRUE if the direction of the slice is known. @@ -834,7 +834,10 @@ package body Trans.Chap6 is Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); El_Info : Field_Info_Acc; Base_Tinfo : Type_Info_Acc; - Stable_Prefix, Base, Res, Fat_Res : Mnode; + Stable_Prefix : Mnode; + Base, Res, Fat_Res : Mnode; + Rec_Layout : Mnode; + El_Descr : Mnode; Box_Field : O_Fnode; B : O_Lnode; begin @@ -856,26 +859,26 @@ package body Trans.Chap6 is Stable_Prefix := Stabilize (Prefix); -- Result is a fat pointer, create it and set bounds. + -- FIXME: layout for record, bounds for array! Fat_Res := Create_Temp (El_Tinfo, Kind); - New_Assign_Stmt - (M2Lp (Chap3.Get_Composite_Bounds (Fat_Res)), - New_Address - (New_Selected_Element - (M2Lv (Chap3.Get_Composite_Bounds (Stable_Prefix)), - El_Info.Field_Bound), - El_Tinfo.B.Bounds_Ptr_Type)); + El_Descr := Chap3.Record_Layout_To_Element_Layout + (Chap3.Get_Composite_Bounds (Stable_Prefix), El); + case El_Tinfo.Type_Mode is + when Type_Mode_Unbounded_Record => + null; + when Type_Mode_Unbounded_Array => + El_Descr := Chap3.Layout_To_Bounds (El_Descr); + when others => + raise Internal_Error; + end case; + New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Fat_Res)), + M2Addr (El_Descr)); else Stable_Prefix := Prefix; end if; - if Get_Type_Info (Stable_Prefix).Type_Mode = Type_Mode_Unbounded_Record - then - -- Get the base. - Base := Chap3.Get_Composite_Base (Stable_Prefix); - else - -- Might be a boxed subtype; keep the box to optimize the access. - Base := Stable_Prefix; - end if; + -- Get the base. + Base := Chap3.Get_Composite_Base (Stable_Prefix); Base_Tinfo := Get_Type_Info (Base); Box_Field := Base_Tinfo.S.Box_Field (Kind); @@ -895,6 +898,7 @@ package body Trans.Chap6 is end if; -- The element is complex: it's an offset. + Rec_Layout := Chap3.Get_Composite_Bounds (Stable_Prefix); Res := E2M (New_Unchecked_Address (New_Slice @@ -902,8 +906,8 @@ package body Trans.Chap6 is (New_Unchecked_Address (M2Lv (Base), Char_Ptr_Type)), Chararray_Type, New_Value - (New_Selected_Element (B, - El_Info.Field_Node (Kind)))), + (Chap3.Record_Layout_To_Element_Offset + (Rec_Layout, El, Kind))), El_Tinfo.B.Base_Ptr_Type (Kind)), El_Tinfo, Kind); else diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index 614f993f3..e93dce632 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -65,7 +65,7 @@ package body Trans.Chap7 is Val : Var_Type; Res : O_Cnode; List : O_Record_Aggr_List; - Bound : Var_Type; + Layout : Var_Type; begin if Res_Type = Expr_Type then return Expr; @@ -96,22 +96,24 @@ package body Trans.Chap7 is Val := Create_Global_Const (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), O_Storage_Private, Expr); - Bound := Expr_Info.S.Composite_Bounds; - if Bound = Null_Var then - Bound := Create_Global_Const - (Create_Uniq_Identifier, Expr_Info.B.Bounds_Type, + Layout := Expr_Info.S.Composite_Layout; + if Layout = Null_Var then + Layout := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.B.Layout_Type, O_Storage_Private, - Chap3.Create_Static_Composite_Subtype_Bounds (Expr_Type)); - Expr_Info.S.Composite_Bounds := Bound; + Chap3.Create_Static_Composite_Subtype_Layout (Expr_Type)); + Expr_Info.S.Composite_Layout := Layout; end if; Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value)); New_Record_Aggr_El - (List, New_Global_Address (Get_Var_Label (Val), - Res_Info.B.Base_Ptr_Type (Mode_Value))); + (List, New_Global_Address (New_Global (Get_Var_Label (Val)), + Res_Info.B.Base_Ptr_Type (Mode_Value))); New_Record_Aggr_El - (List, New_Global_Address (Get_Var_Label (Bound), - Expr_Info.B.Bounds_Ptr_Type)); + (List, New_Global_Address (New_Global_Selected_Element + (New_Global (Get_Var_Label (Layout)), + Expr_Info.B.Layout_Bounds), + Expr_Info.B.Bounds_Ptr_Type)); Finish_Record_Aggr (List, Res); return Res; @@ -375,12 +377,12 @@ package body Trans.Chap7 is Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); New_Record_Aggr_El (Res_Aggr, - New_Global_Address (Get_Var_Label (Val), - Type_Info.B.Base_Ptr_Type (Mode_Value))); + New_Global_Address (New_Global (Get_Var_Label (Val)), + Type_Info.B.Base_Ptr_Type (Mode_Value))); New_Record_Aggr_El (Res_Aggr, - New_Global_Address (Get_Var_Label (Bound), - Type_Info.B.Bounds_Ptr_Type)); + New_Global_Address (New_Global (Get_Var_Label (Bound)), + Type_Info.B.Bounds_Ptr_Type)); Finish_Record_Aggr (Res_Aggr, Res); Val := Create_Global_Const @@ -818,7 +820,7 @@ package body Trans.Chap7 is Atype_El_Type := Get_Type (Atype_El); if Expr_El_Type /= Atype_El_Type then Convert_To_Constrained_Check - (Chap3.Bounds_To_Element_Bounds + (Chap3.Record_Bounds_To_Element_Bounds (Stable_Bounds, Expr_El), Expr_El_Type, Atype_El_Type, Failure_Label); end if; @@ -2626,8 +2628,7 @@ package body Trans.Chap7 is return Translate_To_String (Subprg, Res_Type, Expr, New_Convert_Ov (Left_Tree, Conv), - New_Lit (Rtis.New_Rti_Address - (Get_Info (Left_Type).Type_Rti))); + Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti)); end; when Iir_Predefined_Floating_To_String => return Translate_To_String @@ -2661,15 +2662,13 @@ package body Trans.Chap7 is return Translate_To_String (Subprg, Res_Type, Expr, New_Convert_Ov (Left_Tree, Conv), - New_Lit (Rtis.New_Rti_Address - (Get_Info (Left_Type).Type_Rti))); + Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti)); end; when Iir_Predefined_Time_To_String_Unit => return Translate_To_String (Ghdl_Time_To_String_Unit, Res_Type, Expr, Left_Tree, Right_Tree, - New_Lit (Rtis.New_Rti_Address - (Get_Info (Left_Type).Type_Rti))); + Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti)); when Iir_Predefined_Bit_Vector_To_Ostring => return Translate_Bv_To_String (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Expr); @@ -2699,8 +2698,7 @@ package body Trans.Chap7 is New_Convert_Ov (M2E (Chap3.Get_Composite_Base (Arg)), Ghdl_Ptr_Type), Chap3.Get_Array_Length (Arg, Left_Type), - New_Lit (Rtis.New_Rti_Address - (Get_Info (El_Type).Type_Rti))); + Rtis.New_Rti_Address (Get_Info (El_Type).Type_Rti)); end; when others => @@ -3551,7 +3549,7 @@ package body Trans.Chap7 is Val_Size := Create_Temp_Init (Ghdl_Index_Type, Chap3.Get_Subtype_Size - (D_Type, Chap3.Get_Array_Type_Bounds (Sub_Type), + (D_Type, Chap3.Get_Composite_Type_Bounds (Sub_Type), Mode_Value)); -- Size of the bounds. @@ -3569,14 +3567,12 @@ package body Trans.Chap7 is A_Info.Ortho_Type (Mode_Value))); -- Copy bounds. - Gen_Memcpy - (New_Obj_Value (Ptr), - M2Addr (Chap3.Get_Array_Type_Bounds (Sub_Type)), - New_Lit (Bounds_Size)); + Gen_Memcpy (New_Obj_Value (Ptr), + M2Addr (Chap3.Get_Composite_Type_Bounds (Sub_Type)), + New_Lit (Bounds_Size)); -- Create a fat pointer to initialize the object. Res := Bounds_Acc_To_Fat_Pointer (Ptr, A_Type); - Chap3.Maybe_Call_Type_Builder (Res, D_Type); Chap4.Init_Object (Res, D_Type); return New_Obj_Value (Ptr); diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb index 8fc959ab5..318d0142f 100644 --- a/src/vhdl/translate/trans-chap8.adb +++ b/src/vhdl/translate/trans-chap8.adb @@ -2713,7 +2713,8 @@ package body Trans.Chap8 is if Mode = Mode_Value then if Get_Type_Staticness (Actual_Type) >= Globally then Chap3.Create_Array_Subtype (Actual_Type); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Bounds := + Chap3.Get_Composite_Type_Bounds (Actual_Type); Chap3.Translate_Object_Allocation (Param, Alloc, Formal_Type, Bounds); else @@ -2877,7 +2878,7 @@ package body Trans.Chap8 is Stabilize (Saved_Val (Pos)); Chap3.Copy_Bounds - (Chap3.Bounds_To_Element_Bounds + (Chap3.Record_Bounds_To_Element_Bounds (Chap3.Get_Composite_Bounds (Params (Last_Individual)), Get_Selected_Element (Formal)), diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb index 10bd3233f..669f86ee4 100644 --- a/src/vhdl/translate/trans-chap9.adb +++ b/src/vhdl/translate/trans-chap9.adb @@ -925,7 +925,7 @@ package body Trans.Chap9 is (New_Selected_Element (Get_Instance_Ref (Ref_Scope), Comp_Field), Rtis.Ghdl_Component_Link_Stmt), - New_Lit (Rtis.Get_Context_Rti (Stmt))); + Rtis.Get_Context_Rti (Stmt)); end Set_Component_Link; Info : constant Block_Info_Acc := Get_Info (Stmt); @@ -2523,9 +2523,8 @@ package body Trans.Chap9 is New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association - (Assoc, - New_Lit (New_Global_Unchecked_Address - (Get_Info (Sig).Signal_Rti, Rtis.Ghdl_Rti_Access))); + (Assoc, New_Unchecked_Address (New_Obj (Get_Info (Sig).Signal_Rti), + Rtis.Ghdl_Rti_Access)); New_Procedure_Call (Assoc); end Merge_Signals_Rti_Non_Composite; diff --git a/src/vhdl/translate/trans-helpers2.adb b/src/vhdl/translate/trans-helpers2.adb index b0cc37d58..1886ccab5 100644 --- a/src/vhdl/translate/trans-helpers2.adb +++ b/src/vhdl/translate/trans-helpers2.adb @@ -108,8 +108,8 @@ package body Trans.Helpers2 is Unsigned_64 (Str'Length)); Start_Record_Aggr (List, Ghdl_Str_Len_Type_Node); New_Record_Aggr_El (List, Str_Len); - New_Record_Aggr_El (List, New_Global_Address (Str_Cst, - Char_Ptr_Type)); + New_Record_Aggr_El (List, New_Global_Address (New_Global (Str_Cst), + Char_Ptr_Type)); Finish_Record_Aggr (List, Res); return Res; end Create_String_Len; @@ -283,10 +283,11 @@ package body Trans.Helpers2 is procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; Line : Natural) is begin - New_Association (Assoc, - New_Lit (New_Global_Address (Current_Filename_Node, - Char_Ptr_Type))); - New_Association (Assoc, New_Lit (New_Signed_Literal - (Ghdl_I32_Type, Integer_64 (Line)))); + New_Association + (Assoc, New_Address (New_Obj (Current_Filename_Node), + Char_Ptr_Type)); + New_Association + (Assoc, New_Lit (New_Signed_Literal (Ghdl_I32_Type, + Integer_64 (Line)))); end Assoc_Filename_Line; end Trans.Helpers2; diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb index 268c4fb9d..0ab7a1bf9 100644 --- a/src/vhdl/translate/trans-rtis.adb +++ b/src/vhdl/translate/trans-rtis.adb @@ -110,9 +110,7 @@ package body Trans.Rtis is Ghdl_Rtin_Subtype_Composite_Common : O_Fnode; Ghdl_Rtin_Subtype_Composite_Name : O_Fnode; Ghdl_Rtin_Subtype_Composite_Basetype : O_Fnode; - Ghdl_Rtin_Subtype_Composite_Bounds : O_Fnode; - Ghdl_Rtin_Subtype_Composite_Valsize : O_Fnode; - Ghdl_Rtin_Subtype_Composite_Sigsize : O_Fnode; + Ghdl_Rtin_Subtype_Composite_Layout : O_Fnode; -- Node for a record element. Ghdl_Rtin_Element : O_Tnode; @@ -121,6 +119,7 @@ package body Trans.Rtis is Ghdl_Rtin_Element_Type : O_Fnode; Ghdl_Rtin_Element_Valoff : O_Fnode; Ghdl_Rtin_Element_Sigoff : O_Fnode; + Ghdl_Rtin_Element_Layout : O_Fnode; -- Node for a record type. Ghdl_Rtin_Type_Record : O_Tnode; @@ -128,8 +127,7 @@ package body Trans.Rtis is Ghdl_Rtin_Type_Record_Name : O_Fnode; Ghdl_Rtin_Type_Record_Nbrel : O_Fnode; Ghdl_Rtin_Type_Record_Elements : O_Fnode; - --Ghdl_Rtin_Type_Record_Valsize : O_Fnode; - --Ghdl_Rtin_Type_Record_Sigsize : O_Fnode; + Ghdl_Rtin_Type_Record_Layout : O_Fnode; -- Node for an object. Ghdl_Rtin_Object : O_Tnode; @@ -155,6 +153,10 @@ package body Trans.Rtis is Ghdl_Rtin_Component_Nbr_Child : O_Fnode; Ghdl_Rtin_Component_Children : O_Fnode; + Null_Loc : O_Cnode; + + function Get_Context_Rti (Node : Iir) return O_Dnode; + -- Create all the declarations for RTIs. procedure Rti_Initialize is begin @@ -613,12 +615,8 @@ package body Trans.Rtis is Get_Identifier ("name"), Char_Ptr_Type); New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Basetype, Get_Identifier ("basetype"), Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Bounds, - Get_Identifier ("bounds"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Valsize, - Get_Identifier ("val_size"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Sigsize, - Get_Identifier ("sig_size"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Layout, + Get_Identifier ("layout"), Ghdl_Ptr_Type); Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Composite); New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_composite"), Ghdl_Rtin_Subtype_Composite); @@ -637,6 +635,8 @@ package body Trans.Rtis is Get_Identifier ("nbrel"), Ghdl_Index_Type); New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Elements, Get_Identifier ("elements"), Ghdl_Rti_Arr_Acc); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Layout, + Get_Identifier ("layout"), Ghdl_Ptr_Type); Finish_Record_Type (Constr, Ghdl_Rtin_Type_Record); New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_record"), Ghdl_Rtin_Type_Record); @@ -657,6 +657,8 @@ package body Trans.Rtis is Get_Identifier ("val_off"), Ghdl_Index_Type); New_Record_Field (Constr, Ghdl_Rtin_Element_Sigoff, Get_Identifier ("sig_off"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Element_Layout, + Get_Identifier ("layout_off"), Ghdl_Index_Type); Finish_Record_Type (Constr, Ghdl_Rtin_Element); New_Type_Decl (Get_Identifier ("__ghdl_rtin_element"), Ghdl_Rtin_Element); @@ -722,6 +724,7 @@ package body Trans.Rtis is Ghdl_Rtin_Component); end; + Null_Loc := New_Null_Access (Ghdl_Ptr_Type); end Rti_Initialize; package Rti_Builders is @@ -891,8 +894,8 @@ package body Trans.Rtis is for I in Cur_Block.List.Rtis'Range loop exit when I > Nbr; New_Array_Aggr_El - (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I), - Ghdl_Rti_Access)); + (List, New_Global_Unchecked_Address + (New_Global (Cur_Block.List.Rtis (I)), Ghdl_Rti_Access)); end loop; -- Next chunks. @@ -902,7 +905,7 @@ package body Trans.Rtis is for I in L.Rtis'Range loop exit when I > Nbr; New_Array_Aggr_El - (List, New_Global_Unchecked_Address (L.Rtis (I), + (List, New_Global_Unchecked_Address (New_Global (L.Rtis (I)), Ghdl_Rti_Access)); end loop; L := L.Next; @@ -997,22 +1000,25 @@ package body Trans.Rtis is end if; end Generate_Name; - function Get_Null_Loc return O_Cnode is - begin - return New_Null_Access (Ghdl_Ptr_Type); - end Get_Null_Loc; - - function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode - is + function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode is begin if Is_Var_Field (Var) then return Get_Var_Offset (Var, Ghdl_Ptr_Type); else - return New_Global_Unchecked_Address (Get_Var_Label (Var), + return New_Global_Unchecked_Address (New_Global (Get_Var_Label (Var)), Ghdl_Ptr_Type); end if; end Var_Acc_To_Loc; + function Var_Acc_To_Loc_Maybe (Var : Var_Type) return O_Cnode is + begin + if Var = Null_Var then + return Null_Loc; + else + return Var_Acc_To_Loc (Var); + end if; + end Var_Acc_To_Loc_Maybe; + -- Generate a name constant for the name of type definition DEF. -- If DEF is an anonymous subtype, returns O_LNODE_NULL. -- Use function NEW_NAME_ADDRESS (defined below) to convert the @@ -1038,13 +1044,19 @@ package body Trans.Rtis is if Name = O_Dnode_Null then return New_Null_Access (Char_Ptr_Type); else - return New_Global_Unchecked_Address (Name, Char_Ptr_Type); + return New_Global_Unchecked_Address (New_Global (Name), + Char_Ptr_Type); end if; end New_Name_Address; function New_Rti_Address (Rti : O_Dnode) return O_Cnode is begin - return New_Global_Unchecked_Address (Rti, Ghdl_Rti_Access); + return New_Global_Unchecked_Address (New_Global (Rti), Ghdl_Rti_Access); + end New_Rti_Address; + + function New_Rti_Address (Rti : O_Dnode) return O_Enode is + begin + return New_Unchecked_Address (New_Obj (Rti), Ghdl_Rti_Access); end New_Rti_Address; -- Declare the RTI constant for type definition attached to INFO. @@ -1109,8 +1121,7 @@ package body Trans.Rtis is Start_Init_Value (Name_Arr); Start_Array_Aggr (Arr_Aggr, Name_Arr_Type); for I in Name_Lits'Range loop - New_Array_Aggr_El - (Arr_Aggr, New_Global_Address (Name_Lits (I), Char_Ptr_Type)); + New_Array_Aggr_El (Arr_Aggr, New_Name_Address (Name_Lits (I))); end loop; Finish_Array_Aggr (Arr_Aggr, Val); Finish_Init_Value (Name_Arr, Val); @@ -1131,12 +1142,10 @@ package body Trans.Rtis is Start_Record_Aggr (Rec_Aggr, Ghdl_Rtin_Type_Enum); New_Record_Aggr_El (Rec_Aggr, Generate_Common_Type (Kind, 0, 0)); New_Record_Aggr_El (Rec_Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Rec_Aggr, New_Index_Lit (Unsigned_64 (Nbr_Lit))); New_Record_Aggr_El - (Rec_Aggr, New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Nbr_Lit))); - New_Record_Aggr_El - (Rec_Aggr, - New_Global_Address (Name_Arr, Char_Ptr_Array_Ptr_Type)); + (Rec_Aggr, New_Global_Address (New_Global (Name_Arr), + Char_Ptr_Array_Ptr_Type)); Finish_Record_Aggr (Rec_Aggr, Val); Finish_Init_Value (Info.Type_Rti, Val); end; @@ -1210,7 +1219,7 @@ package body Trans.Rtis is -- Handle non-static units. The only possibility is a unit of -- std.standard.time. Val := New_Global_Unchecked_Address - (Get_Var_Label (Info.Object_Var), Ghdl_Ptr_Type); + (New_Global (Get_Var_Label (Info.Object_Var)), Ghdl_Ptr_Type); else Val := Chap7.Translate_Numeric_Literal (Unit, Ghdl_I64_Type); end if; @@ -1263,12 +1272,9 @@ package body Trans.Rtis is end case; New_Record_Aggr_El (List, Generate_Common_Type (Rti_Kind, 0, 0, 0)); New_Record_Aggr_El (List, New_Name_Address (Name)); - New_Record_Aggr_El - (List, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Nbr_Units))); - New_Record_Aggr_El - (List, New_Global_Address (Unit_Arr, Ghdl_Rti_Arr_Acc)); + New_Record_Aggr_El (List, New_Index_Lit (Unsigned_64 (Nbr_Units))); + New_Record_Aggr_El (List, New_Global_Address (New_Global (Unit_Arr), + Ghdl_Rti_Arr_Acc)); Finish_Record_Aggr (List, Val); Finish_Init_Value (Info.Type_Rti, Val); end Generate_Physical_Type_Definition; @@ -1499,10 +1505,9 @@ package body Trans.Rtis is New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Rti_Address (El_Info.Type_Rti)); New_Record_Aggr_El - (Aggr, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Get_Nbr_Elements (List)))); - New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + (Aggr, New_Index_Lit (Unsigned_64 (Get_Nbr_Elements (List)))); + New_Record_Aggr_El (Aggr, New_Global_Address (New_Global (Arr), + Ghdl_Rti_Arr_Acc)); Finish_Record_Aggr (Aggr, Val); Finish_Init_Value (Info.Type_Rti, Val); end Generate_Array_Type_Definition; @@ -1521,7 +1526,7 @@ package body Trans.Rtis is Kind : O_Cnode; Depth : Rti_Depth_Type; begin - Bounds := Info.S.Composite_Bounds; + Bounds := Info.S.Composite_Layout; Depth := Get_Depth_From_Var (Bounds); Info.B.Rti_Max_Depth := Rti_Depth_Type'Max (Depth, Base_Info.B.Rti_Max_Depth); @@ -1555,39 +1560,7 @@ package body Trans.Rtis is (Kind, Depth, Info.B.Rti_Max_Depth, Type_To_Mode (Atype))); New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); - if Bounds = Null_Var then - Val := Get_Null_Loc; - else - Val := Var_Acc_To_Loc (Bounds); - end if; - New_Record_Aggr_El (Aggr, Val); - for I in Mode_Value .. Mode_Signal loop - case Info.Type_Mode is - when Type_Mode_Static_Array - | Type_Mode_Static_Record => - if Info.Ortho_Type (I) /= O_Tnode_Null then - Val := New_Sizeof (Info.Ortho_Type (I), Ghdl_Ptr_Type); - else - Val := Get_Null_Loc; - end if; - when Type_Mode_Complex_Array - | Type_Mode_Complex_Record => - if Info.Ortho_Type (I) /= O_Tnode_Null - and then Info.C (I).Size_Var /= Null_Var - then - Val := Var_Acc_To_Loc (Info.C (I).Size_Var); - else - Val := Get_Null_Loc; - end if; - when Type_Mode_Unbounded_Array - | Type_Mode_Unbounded_Record => - Val := Get_Null_Loc; - when others => - Error_Kind ("generate_composite_subtype_definition", Atype); - end case; - New_Record_Aggr_El (Aggr, Val); - end loop; - + New_Record_Aggr_El (Aggr, Var_Acc_To_Loc_Maybe (Bounds)); Finish_Record_Aggr (Aggr, Val); Finish_Init_Value (Info.Type_Rti, Val); end Generate_Composite_Subtype_Definition; @@ -1640,12 +1613,14 @@ package body Trans.Rtis is El := Get_Nth_Element (El_List, I); declare El_Type : constant Iir := Get_Type (El); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); Field_Info : constant Field_Info_Acc := Get_Info (El); Type_Rti : O_Dnode; El_Name : O_Dnode; Aggr : O_Record_Aggr_List; Val : O_Cnode; El_Const : O_Dnode; + Mode : Natural; Mark : Id_Mark_Type; begin Push_Identifier_Prefix (Mark, Get_Identifier (El)); @@ -1655,25 +1630,51 @@ package body Trans.Rtis is Rti_Depth_Type'Max (Max_Depth, Get_Info (El_Type).B.Rti_Max_Depth); + case El_Tinfo.Type_Mode is + when Type_Mode_Unbounded_Array + | Type_Mode_Unbounded_Record => + Mode := 2; + when Type_Mode_Complex_Record + | Type_Mode_Complex_Array => + Mode := 1; + when others => + Mode := 0; + end case; El_Name := Generate_Name (El); New_Const_Decl (El_Const, Create_Identifier ("RTIEL"), Global_Storage, Ghdl_Rtin_Element); Start_Init_Value (El_Const); Start_Record_Aggr (Aggr, Ghdl_Rtin_Element); - New_Record_Aggr_El (Aggr, - Generate_Common (Ghdl_Rtik_Element)); + New_Record_Aggr_El + (Aggr, Generate_Common (Ghdl_Rtik_Element, Mode => Mode)); New_Record_Aggr_El (Aggr, New_Name_Address (El_Name)); New_Record_Aggr_El (Aggr, New_Rti_Address (Type_Rti)); for I in Object_Kind_Type loop if Field_Info.Field_Node (I) /= O_Fnode_Null then - Val := New_Offsetof (Info.B.Base_Type (I), - Field_Info.Field_Node (I), - Ghdl_Index_Type); + if Is_Static_Type (El_Tinfo) then + Val := New_Offsetof (Info.B.Base_Type (I), + Field_Info.Field_Node (I), + Ghdl_Index_Type); + else + Val := New_Offsetof (Info.B.Bounds_Type, + Field_Info.Field_Node (I), + Ghdl_Index_Type); + end if; else Val := Ghdl_Index_0; end if; New_Record_Aggr_El (Aggr, Val); end loop; + + if Is_Unbounded_Type (El_Tinfo) then + Val := New_Offsetof (Info.B.Bounds_Type, + Field_Info.Field_Bound, + Ghdl_Index_Type); + else + Val := Ghdl_Index_0; + end if; + New_Record_Aggr_El (Aggr, Val); + Finish_Record_Aggr (Aggr, Val); Finish_Init_Value (El_Const, Val); Add_Rti_Node (El_Const); @@ -1690,25 +1691,33 @@ package body Trans.Rtis is Aggr : O_Record_Aggr_List; Name : O_Dnode; Rtik : O_Cnode; + Depth : Rti_Depth_Type; + Layout_Loc : O_Cnode; begin Name := Generate_Type_Name (Atype); Start_Init_Value (Info.Type_Rti); Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Record); + Depth := 0; + Layout_Loc := Null_Loc; if Get_Constraint_State (Atype) = Fully_Constrained then Rtik := Ghdl_Rtik_Type_Record; + if Info.S.Composite_Layout /= Null_Var then + Depth := Get_Depth_From_Var (Info.S.Composite_Layout); + Layout_Loc := Var_Acc_To_Loc (Info.S.Composite_Layout); + end if; else Rtik := Ghdl_Rtik_Type_Unbounded_Record; end if; New_Record_Aggr_El - (Aggr, - Generate_Common_Type (Rtik, 0, Max_Depth, Type_To_Mode (Atype))); + (Aggr, Generate_Common_Type + (Rtik, Depth, Max_Depth, Type_To_Mode (Atype))); New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El - (Aggr, New_Unsigned_Literal - (Ghdl_Index_Type, Unsigned_64 (Get_Nbr_Elements (El_List)))); - New_Record_Aggr_El (Aggr, - New_Global_Address (El_Arr, Ghdl_Rti_Arr_Acc)); + (Aggr, New_Index_Lit (Unsigned_64 (Get_Nbr_Elements (El_List)))); + New_Record_Aggr_El (Aggr, New_Global_Address (New_Global (El_Arr), + Ghdl_Rti_Arr_Acc)); + New_Record_Aggr_El (Aggr, Layout_Loc); Finish_Record_Aggr (Aggr, Res); Finish_Init_Value (Info.Type_Rti, Res); end; @@ -1993,12 +2002,7 @@ package body Trans.Rtis is end case; New_Record_Aggr_El (List, Generate_Common (Comm, Var, Mode)); New_Record_Aggr_El (List, New_Name_Address (Name)); - if Var = Null_Var then - Val := Get_Null_Loc; - else - Val := Var_Acc_To_Loc (Var); - end if; - New_Record_Aggr_El (List, Val); + New_Record_Aggr_El (List, Var_Acc_To_Loc_Maybe (Var)); Val := New_Rti_Address (Type_Info.Type_Rti); New_Record_Aggr_El (List, Val); New_Record_Aggr_El (List, Generate_Linecol (Decl)); @@ -2091,13 +2095,10 @@ package body Trans.Rtis is Start_Init_Value (Info.Comp_Rti_Const); Start_Record_Aggr (List, Ghdl_Rtin_Component); New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Component)); - New_Record_Aggr_El (List, - New_Global_Address (Name, Char_Ptr_Type)); - New_Record_Aggr_El - (List, New_Unsigned_Literal (Ghdl_Index_Type, - Get_Rti_Array_Length)); - New_Record_Aggr_El (List, - New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + New_Record_Aggr_El (List, New_Index_Lit (Get_Rti_Array_Length)); + New_Record_Aggr_El (List, New_Global_Address (New_Global (Arr), + Ghdl_Rti_Arr_Acc)); Finish_Record_Aggr (List, Res); Finish_Init_Value (Info.Comp_Rti_Const, Res); Pop_Rti_Node (Prev); @@ -2201,7 +2202,7 @@ package body Trans.Rtis is Start_Init_Value (Info.Block_Rti_Const); Start_Record_Aggr (List, Ghdl_Rtin_Instance); New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Instance)); - New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El (List, New_Name_Address (Name)); New_Record_Aggr_El (List, Generate_Linecol (Stmt)); New_Record_Aggr_El (List, New_Offsetof (Get_Scope_Type @@ -2495,7 +2496,7 @@ package body Trans.Rtis is Start_Record_Aggr (List, Ghdl_Rtin_Block); New_Record_Aggr_El (List, Generate_Common (Rtik)); - New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El (List, New_Name_Address (Name)); -- Field Loc: offset in the instance of the entity. Field_Off := New_Offsetof @@ -2511,7 +2512,8 @@ package body Trans.Rtis is -- Fields Nbr_Child and Children. New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Index_Type, Get_Rti_Array_Length)); - New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + New_Record_Aggr_El (List, New_Global_Address (New_Global (Arr), + Ghdl_Rti_Arr_Acc)); Finish_Record_Aggr (List, Res); Finish_Init_Value (Rti, Res); @@ -2557,7 +2559,7 @@ package body Trans.Rtis is Start_Record_Aggr (List, Ghdl_Rtin_Generate); New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_For_Generate)); - New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El (List, New_Name_Address (Name)); -- Field Loc: offset in the instance of the entity. Field_Off := New_Offsetof @@ -2578,7 +2580,7 @@ package body Trans.Rtis is Ghdl_Index_Type)); -- Child. - New_Record_Aggr_El (List, Get_Context_Rti (Bod)); + New_Record_Aggr_El (List, New_Rti_Address (Get_Context_Rti (Bod))); Finish_Record_Aggr (List, Res); @@ -2716,17 +2718,17 @@ package body Trans.Rtis is Start_Record_Aggr (List, Ghdl_Rtin_Block); New_Record_Aggr_El (List, Generate_Common (Kind)); - New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El (List, New_Name_Address (Name)); -- Field Loc: offset in the instance of the entity. if Field_Off = O_Cnode_Null then - Field_Off := Get_Null_Loc; + Field_Off := Null_Loc; end if; New_Record_Aggr_El (List, Field_Off); New_Record_Aggr_El (List, Generate_Linecol (Blk)); - -- Field Parent: RTI of the parent. + -- Field Parent: RTI of the parent. if Parent_Rti = O_Dnode_Null then Res := New_Null_Access (Ghdl_Rti_Access); else @@ -2736,14 +2738,14 @@ package body Trans.Rtis is -- Fields Nbr_Child and Children. New_Record_Aggr_El (List, New_Index_Lit (Get_Rti_Array_Length)); - New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + New_Record_Aggr_El (List, New_Global_Address (New_Global (Arr), + Ghdl_Rti_Arr_Acc)); Finish_Record_Aggr (List, Res); if Rti_Type = Ghdl_Rtin_Block_File then New_Record_Aggr_El (List_File, Res); New_Record_Aggr_El (List_File, - New_Global_Address (Current_Filename_Node, - Char_Ptr_Type)); + New_Name_Address (Current_Filename_Node)); Finish_Record_Aggr (List_File, Res); end if; @@ -2945,43 +2947,46 @@ package body Trans.Rtis is Pop_Rti_Node (Prev); end Generate_Top; - function Get_Context_Rti (Node : Iir) return O_Cnode + function Get_Context_Rti (Node : Iir) return O_Dnode is Node_Info : constant Ortho_Info_Acc := Get_Info (Node); - Rti_Const : O_Dnode; begin case Get_Kind (Node) is when Iir_Kind_Component_Declaration => - Rti_Const := Node_Info.Comp_Rti_Const; + return Node_Info.Comp_Rti_Const; when Iir_Kind_Component_Instantiation_Statement => - Rti_Const := Node_Info.Block_Rti_Const; + return Node_Info.Block_Rti_Const; when Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement_Body => - Rti_Const := Node_Info.Block_Rti_Const; + return Node_Info.Block_Rti_Const; when Iir_Kind_If_Generate_Statement | Iir_Kind_For_Generate_Statement => declare Bod : constant Iir := Get_Generate_Statement_Body (Node); Bod_Info : constant Block_Info_Acc := Get_Info (Bod); begin - Rti_Const := Bod_Info.Block_Rti_Const; + return Bod_Info.Block_Rti_Const; end; when Iir_Kind_Package_Declaration | Iir_Kind_Package_Body => - Rti_Const := Node_Info.Package_Rti_Const; + return Node_Info.Package_Rti_Const; when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => - Rti_Const := Node_Info.Process_Rti_Const; + return Node_Info.Process_Rti_Const; when Iir_Kind_Psl_Assert_Statement | Iir_Kind_Psl_Cover_Statement | Iir_Kind_Psl_Endpoint_Declaration => - Rti_Const := Node_Info.Psl_Rti_Const; + return Node_Info.Psl_Rti_Const; when others => Error_Kind ("get_context_rti", Node); end case; - return New_Rti_Address (Rti_Const); + end Get_Context_Rti; + + function Get_Context_Rti (Node : Iir) return O_Enode is + begin + return New_Rti_Address (Get_Context_Rti (Node)); end Get_Context_Rti; function Get_Context_Addr (Node : Iir) return O_Enode @@ -3024,7 +3029,7 @@ package body Trans.Rtis is procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir) is begin - New_Association (Assoc, New_Lit (Get_Context_Rti (Node))); + New_Association (Assoc, Get_Context_Rti (Node)); New_Association (Assoc, Get_Context_Addr (Node)); end Associate_Rti_Context; diff --git a/src/vhdl/translate/trans-rtis.ads b/src/vhdl/translate/trans-rtis.ads index 73bc514e0..e3c8c188e 100644 --- a/src/vhdl/translate/trans-rtis.ads +++ b/src/vhdl/translate/trans-rtis.ads @@ -114,7 +114,7 @@ package Trans.Rtis is procedure Rti_Initialize; -- Get address (as Ghdl_Rti_Access) of constant RTI. - function New_Rti_Address (Rti : O_Dnode) return O_Cnode; + function New_Rti_Address (Rti : O_Dnode) return O_Enode; -- Generate rtis for a library unit. procedure Generate_Unit (Lib_Unit : Iir); @@ -139,6 +139,6 @@ package Trans.Rtis is (Assoc : in out O_Assoc_List; Node : Iir); procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List); - function Get_Context_Rti (Node : Iir) return O_Cnode; + function Get_Context_Rti (Node : Iir) return O_Enode; function Get_Context_Addr (Node : Iir) return O_Enode; end Trans.Rtis; diff --git a/src/vhdl/translate/trans.adb b/src/vhdl/translate/trans.adb index a2385cbe6..4d6a0a44a 100644 --- a/src/vhdl/translate/trans.adb +++ b/src/vhdl/translate/trans.adb @@ -1133,6 +1133,24 @@ package body Trans is end Instantiate_Var_Scope; end Chap10; + function Align_Val (Algn : Alignment_Type) return O_Cnode is + begin + case Algn is + when Align_Undef => + raise Internal_Error; + when Align_8 => + return Ghdl_Index_1; + when Align_16 => + return Ghdl_Index_2; + when Align_32 => + return Ghdl_Index_4; + when Align_Ptr => + return Ghdl_Index_Ptr_Align; + when Align_64 => + return Ghdl_Index_8; + end case; + end Align_Val; + function Get_Object_Kind (M : Mnode) return Object_Kind_Type is begin return M.M1.K; @@ -1401,9 +1419,6 @@ package body Trans is procedure Free_Type_Info (Info : in out Type_Info_Acc) is begin - if Info.C /= null then - Free_Complex_Type_Info (Info.C); - end if; Unchecked_Deallocation (Info); end Free_Type_Info; @@ -1433,7 +1448,26 @@ package body Trans is function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is begin - return Tinfo.C /= null; + case Tinfo.Type_Mode is + when Type_Mode_Non_Composite => + return False; + when Type_Mode_Static_Record + | Type_Mode_Static_Array => + return False; + when Type_Mode_Complex_Record + | Type_Mode_Complex_Array => + return True; + when Type_Mode_Unbounded_Record + | Type_Mode_Unbounded_Array => + return False; + when Type_Mode_Protected => + -- Considered as a complex type, as its size is known only in + -- the body. + -- Shouldn't be used. + raise Internal_Error; + when Type_Mode_Unknown => + return False; + end case; end Is_Complex_Type; function Is_Static_Type (Tinfo : Type_Info_Acc) return Boolean is @@ -1480,13 +1514,6 @@ package body Trans is Clear_Info (I); else Info.Mark := True; - if Info.Kind = Kind_Type and then Info.C /= null then - if Info.C (Mode_Value).Mark then - Info.C := null; - else - Info.C (Mode_Value).Mark := True; - end if; - end if; end if; end if; end loop; diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads index 8b6888764..960323ee8 100644 --- a/src/vhdl/translate/trans.ads +++ b/src/vhdl/translate/trans.ads @@ -68,6 +68,10 @@ package Trans is Ghdl_Index_Type : O_Tnode; Ghdl_Index_0 : O_Cnode; Ghdl_Index_1 : O_Cnode; + Ghdl_Index_2 : O_Cnode; + Ghdl_Index_4 : O_Cnode; + Ghdl_Index_8 : O_Cnode; + Ghdl_Index_Ptr_Align : O_Cnode; -- Alignment of a pointer -- Type for a file (this is in fact a index in a private table). Ghdl_File_Index_Type : O_Tnode; @@ -105,6 +109,9 @@ package Trans is Ghdl_Sizes_Val : O_Fnode; Ghdl_Sizes_Sig : O_Fnode; + -- Access to size. + Ghdl_Sizes_Ptr : O_Tnode; + -- Comparaison type. Ghdl_Compare_Type : O_Tnode; Ghdl_Compare_Lt : O_Cnode; @@ -750,6 +757,58 @@ package Trans is type Rti_Depth_Type is new Natural range 0 .. 255; + -- Additional info for complex types. + type Complex_Type_Info is record + -- Parameters for type builders. + -- NOTE: this is only set for types (and *not* for subtypes). + Builder_Instance : Subprgs.Subprg_Instance_Type; + Builder_Layout_Param : O_Dnode; + Builder_Proc : O_Dnode := O_Dnode_Null; + end record; + type Complex_Type_Arr_Info is array (Object_Kind_Type) of Complex_Type_Info; + + -- Alignment of a type. + -- This is only for Mode_Value (for Mode_Signal, the alignment is + -- Align_Ptr). + -- The size of complex types is determined at run-time, and the code to + -- compute it is generated by translation. But to know the size, the + -- alignment must also be known. It is assumed that allocators (malloc or + -- alloca) always return a pointer with the maximum alignment. + -- Eg: type cpl_rec is record + -- b : boolean; + -- v : integer_array (1 to n); -- n is a non-locally constant. + -- end record; + -- The static part contains only field 'b'. The whole size is of cpl_rec + -- is: sizeof (b) + align(v) + n * sizeof(integer) + align(cpl_rec). + -- This makes a lot of suppositions about the ABI: + -- * elementary types (including doubles) are always naturally aligned + -- * fields are aligned as their type + -- * records are aligned to their maximum field + -- * pointers have the same size + -- * finally, pointers are either 32 or 64 bits. + -- Note: deviation from the ABI may result in incorrect code as an object + -- that is statically constrained may be viewed as a complex/unbounded + -- object too. + -- Note: These suppositions are true on x86-64, on windows32. + -- but not for double on linux-x86!! + type Alignment_Type is + ( + -- When alignment is not known. + Align_Undef, + + -- For enumerations, integers, physical types. + Align_8, Align_16, Align_32, + + -- For an access. We suppose that pointers are either 32 or 64 bits. + -- So Align_Ptr >= Align_32 but Align_64 >= Align_Ptr + Align_Ptr, + + -- For float64 (floating point types), large integers or large physical + -- types. + Align_64); + + function Align_Val (Algn : Alignment_Type) return O_Cnode; + type Ortho_Info_Basetype_Type (Kind : Ortho_Info_Type_Kind := Kind_Type_Scalar) is record -- For all types: @@ -757,6 +816,8 @@ package Trans is -- the type itself and every types it depends on. Rti_Max_Depth : Rti_Depth_Type; + Align : Alignment_Type; + case Kind is when Kind_Type_Scalar => -- For scalar types: @@ -779,19 +840,38 @@ package Trans is Base_Type : O_Tnode_Array; Base_Ptr_Type : O_Tnode_Array; -- The dope vector. + -- For arrays: + -- range of indexes + -- layout of element (if element is unbounded) + -- For record: + -- offsets of complex elements + -- layout of unbounded elements Bounds_Type : O_Tnode; Bounds_Ptr_Type : O_Tnode; - -- Only for unbounded arrays: element size and bounds in - -- the bounds record - El_Size : O_Fnode; - El_Bounds : O_Fnode; + -- For arrays with unbounded element, the layout field of the + -- bounds type. + Bounds_El : O_Fnode; + + -- Size + bounds. + -- Always created for arrays, created for unbounded and complex + -- records. + Layout_Type : O_Tnode; + Layout_Ptr_Type : O_Tnode; + + -- Size and bounds fields of the layout type. + Layout_Size : O_Fnode; + Layout_Bounds : O_Fnode; -- The ortho type is a fat pointer to the base and the bounds. -- These are the fields of the fat pointer. Base_Field : O_Fnode_Array; Bounds_Field : O_Fnode_Array; + -- Parameters for type builders. + -- NOTE: this is only set for types (and *not* for subtypes). + Builder : Complex_Type_Arr_Info; + when Kind_Type_File => -- Constant containing the signature of the file. File_Signature : O_Dnode; @@ -832,11 +912,8 @@ package Trans is when Kind_Type_Array | Kind_Type_Record => - -- True if the bounds are static. - Static_Bounds : Boolean; - - -- Variable containing the bounds for a constrained type. - Composite_Bounds : Var_Type; + -- Variable containing the layout for a constrained type. + Composite_Layout : Var_Type; -- For a locally constrained record subtype whose base type has -- unbounded elements: the field containing the base record. @@ -863,47 +940,61 @@ package Trans is Ortho_Info_Basetype_Array_Init : constant Ortho_Info_Basetype_Type := (Kind => Kind_Type_Array, Rti_Max_Depth => 0, + Align => Align_Undef, Base_Type => (O_Tnode_Null, O_Tnode_Null), Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null), Bounds_Type => O_Tnode_Null, Bounds_Ptr_Type => O_Tnode_Null, - El_Size => O_Fnode_Null, - El_Bounds => O_Fnode_Null, + Bounds_El => O_Fnode_Null, + Layout_Type => O_Tnode_Null, + Layout_Ptr_Type => O_Tnode_Null, + Layout_Size => O_Fnode_Null, + Layout_Bounds => O_Fnode_Null, Base_Field => (O_Fnode_Null, O_Fnode_Null), - Bounds_Field => (O_Fnode_Null, O_Fnode_Null)); + Bounds_Field => (O_Fnode_Null, O_Fnode_Null), + Builder => (others => (Builder_Instance => Subprgs.Null_Subprg_Instance, + Builder_Layout_Param => O_Dnode_Null, + Builder_Proc => O_Dnode_Null))); Ortho_Info_Subtype_Array_Init : constant Ortho_Info_Subtype_Type := (Kind => Kind_Type_Array, - Static_Bounds => False, - Composite_Bounds => Null_Var, + Composite_Layout => Null_Var, Box_Field => (O_Fnode_Null, O_Fnode_Null)); Ortho_Info_Basetype_Record_Init : constant Ortho_Info_Basetype_Type := (Kind => Kind_Type_Record, Rti_Max_Depth => 0, + Align => Align_Undef, Base_Type => (O_Tnode_Null, O_Tnode_Null), Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null), Bounds_Type => O_Tnode_Null, Bounds_Ptr_Type => O_Tnode_Null, - El_Size => O_Fnode_Null, - El_Bounds => O_Fnode_Null, + Bounds_El => O_Fnode_Null, + Layout_Type => O_Tnode_Null, + Layout_Ptr_Type => O_Tnode_Null, + Layout_Size => O_Fnode_Null, + Layout_Bounds => O_Fnode_Null, Base_Field => (O_Fnode_Null, O_Fnode_Null), - Bounds_Field => (O_Fnode_Null, O_Fnode_Null)); + Bounds_Field => (O_Fnode_Null, O_Fnode_Null), + Builder => (others => (Builder_Instance => Subprgs.Null_Subprg_Instance, + Builder_Layout_Param => O_Dnode_Null, + Builder_Proc => O_Dnode_Null))); Ortho_Info_Subtype_Record_Init : constant Ortho_Info_Subtype_Type := (Kind => Kind_Type_Record, - Static_Bounds => False, - Composite_Bounds => Null_Var, + Composite_Layout => Null_Var, Box_Field => (O_Fnode_Null, O_Fnode_Null)); Ortho_Info_Basetype_File_Init : constant Ortho_Info_Basetype_Type := (Kind => Kind_Type_File, Rti_Max_Depth => 0, + Align => Align_Undef, File_Signature => O_Dnode_Null); Ortho_Info_Basetype_Prot_Init : constant Ortho_Info_Basetype_Type := (Kind => Kind_Type_Protected, Rti_Max_Depth => 0, + Align => Align_Undef, Prot_Scope => Null_Var_Scope, Prot_Prev_Scope => null, Prot_Init_Subprg => O_Dnode_Null, @@ -1071,6 +1162,88 @@ package Trans is -- that doesn't suspend is not decomposed by this mechanism). type State_Type is new Nat32; + -- Translation of types. + -- (Where you understand that VHDL is more complex than C...) + -- + -- 1) For scalar types (integers, physical types, enumeration, floating + -- point types) and pointers, the type is fully known during analysis + -- and translation: + -- a) for integers and physical types, the size is defined by the range. + -- GHDL uses either 32-bit or 64-bit types. + -- b) for enumeration, the size is defined by the number of literals. + -- GHDL uses either 8-bit or 32-bit types. + -- c) for floating-point type, GHDL always uses 64-bit types (Float64). + -- d) for access types, GHDL uses pointers. This is slightly more + -- complex as sometimes it can be a fat pointer, which is a record + -- of two pointers. But in all cases, the size is known. + -- + -- For composite subtypes (arrays and records), there are several cases: + -- + -- 2) Composite types whose sub-elements are statically constrained. + -- Eg: subtype byte is bit_vector (7 downto 0); + -- Eg: subtype word is std_logic_vector (31 downto 0); + -- Eg: type my_bus is record + -- req: bit; + -- ack: bit; + -- data: byte; + -- end record; + -- This still corresponds to C: sizes and offsets are known during + -- translation. + -- However, for arrays a bound variable is created. This variable + -- contains the bounds of the array (left, right and direction) and the + -- length of each bound. This is used both for 'introspection' and for + -- conversion to fat pointers. + -- + -- 3) Unbounded types. This is quite usual for parameters. + -- Eg: procedure disp_hex (v : std_logic_vector); + -- The bounds of an unbounded types are only known during execution, and + -- thus must be passed with the argument. + -- This is not the same case as an object declared with an unbounded + -- type; in that case the bounds are computed during elaboration (or + -- dynamic elaboration). + -- Eg: constant c : std_logic_vector := xxx; + -- + -- For these unbounded types, the interface is translated as a fat + -- pointer, which is a structure containing a base pointer and a bound + -- pointer. The base pointer points to the data while the bound pointer + -- points to the bounds. + -- + -- In some case, we need to convert from a bounded representation to an + -- unbounded representation. This happens while calling a subprogram + -- with a bounded object (and corresponds to a subtype conversion in + -- VHDL terms). In that case a fat pointer is created, using the object + -- as data and the bounds variable as the bounds. The opposite + -- conversion can also happen and we just need to check that the bounds + -- are matching and to keep only the data part. + -- + -- 4) Complex types. Complex is a word used only by GHDL (not defined by + -- VHDL). You need to realize that VHDL types are more powerful than C + -- types as you can declare a type whose size is not known by the + -- compiler. + -- Eg: constant length : natural := call_to_a_complex_function(5); + -- subtype my_word is std_logic_vector (1 to length); + -- type my_bus is record + -- d : my_word; + -- req : std_logic_vector; + -- end record; + -- Clearly, LENGTH is not known during analysis. In many cases it + -- could be known during elaboration but this is not enough as such a + -- construct could also be used within subprograms using a parameter to + -- define a bound. + -- + -- Because the size of these objects is not known during compilation, + -- the objects are allocated dynamically (either on the heap or on the + -- stack) during (dynamic) elaboration. They also comes with a bound + -- variable. + -- + -- For arrays, the bound variable describes the index of the array and + -- the bounds of the elements (if the element is unbounded). + -- + -- For records, the bound variable describes the offset and the bounds + -- of the non-static elements. + -- + + -- OLD: -- Complex types. -- -- A complex type is not a VHDL notion, but a translation notion. @@ -1166,30 +1339,6 @@ package Trans is -- | ... | -- +--------------+ - -- Additional info for complex types. - type Complex_Type_Info is record - -- For a simple memory management: use mark and sweep to free all infos. - Mark : Boolean := False; - - Builder_Need_Func : Boolean := False; - - -- Variable containing the size of the type. - -- This is defined only for types whose size is only known at - -- running time (and not a compile-time). - Size_Var : Var_Type := Null_Var; - - -- Parameters for type builders. - -- NOTE: this is only set for types (and *not* for subtypes). - Builder_Instance : Subprgs.Subprg_Instance_Type; - Builder_Base_Param : O_Dnode; - Builder_Bound_Param : O_Dnode; - Builder_Func : O_Dnode := O_Dnode_Null; - end record; - type Complex_Type_Arr_Info is array (Object_Kind_Type) of Complex_Type_Info; - type Complex_Type_Info_Acc is access Complex_Type_Arr_Info; - procedure Free_Complex_Type_Info is new Ada.Unchecked_Deallocation - (Complex_Type_Arr_Info, Complex_Type_Info_Acc); - type Assoc_Conv_Info is record -- The subprogram created to do the conversion. Subprg : O_Dnode; @@ -1238,9 +1387,6 @@ package Trans is -- of its sub-element (ie being a complex type). Type_Locally_Constrained : Boolean := False; - -- Additionnal info for complex types. - C : Complex_Type_Info_Acc := null; - -- Ortho node which represents the type. -- Type -> Ortho type -- scalar -> scalar @@ -1275,10 +1421,13 @@ package Trans is Index_Field : O_Fnode; when Kind_Field => - -- Node for a record element declaration. + -- For element whose type is static: field in the record. + -- For element whose type is not static: offset field in the + -- bounds. Field_Node : O_Fnode_Array := (O_Fnode_Null, O_Fnode_Null); - -- The field in the dope vector (for unbounded element). + -- The field in the layout record for the layout of the + -- element (for unbounded element). Field_Bound : O_Fnode := O_Fnode_Null; when Kind_Expr => @@ -1709,9 +1858,8 @@ package Trans is function Is_Composite (Info : Type_Info_Acc) return Boolean; pragma Inline (Is_Composite); - -- Type needs to be built. + -- Type is bounded but layout and size are known only during elaboration. function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean; - pragma Inline (Is_Complex_Type); -- Type size is known at compile-time. function Is_Static_Type (Tinfo : Type_Info_Acc) return Boolean; diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index a7ec6e7da..68dd9a300 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -33,6 +33,7 @@ with Trans; with Trans_Decls; use Trans_Decls; with Trans.Chap1; with Trans.Chap2; +with Trans.Chap3; with Trans.Chap4; with Trans.Chap7; with Trans.Chap12; @@ -423,6 +424,9 @@ package body Translation is Ghdl_Index_0 := New_Unsigned_Literal (Ghdl_Index_Type, 0); Ghdl_Index_1 := New_Unsigned_Literal (Ghdl_Index_Type, 1); + Ghdl_Index_2 := New_Unsigned_Literal (Ghdl_Index_Type, 2); + Ghdl_Index_4 := New_Unsigned_Literal (Ghdl_Index_Type, 4); + Ghdl_Index_8 := New_Unsigned_Literal (Ghdl_Index_Type, 8); Ghdl_I32_Type := New_Signed_Type (32); New_Type_Decl (Get_Identifier ("__ghdl_i32"), Ghdl_I32_Type); @@ -453,6 +457,8 @@ package body Translation is Char_Ptr_Type := New_Access_Type (Chararray_Type); New_Type_Decl (Get_Identifier ("__ghdl_char_ptr"), Char_Ptr_Type); + Ghdl_Index_Ptr_Align := New_Alignof (Char_Ptr_Type, Ghdl_Index_Type); + Char_Ptr_Array_Type := New_Array_Type (Char_Ptr_Type, Ghdl_Index_Type); New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array"), Char_Ptr_Array_Type); @@ -531,6 +537,10 @@ package body Translation is Ghdl_Sizes_Type); end; + -- __ghdl_sizes_ptr is access __ghdl_sizes_type; + Ghdl_Sizes_Ptr := New_Access_Type (Ghdl_Sizes_Type); + New_Type_Decl (Get_Identifier ("__ghdl_sizes_ptr"), Ghdl_Sizes_Ptr); + -- Create type ghdl_compare_type is (lt, eq, ge); declare Constr : O_Enum_List; @@ -1906,12 +1916,22 @@ package body Translation is end Post_Initialize; - procedure Translate_Type_Implicit_Subprograms (Decl : in out Iir) + procedure Translate_Type_Implicit_Subprograms + (Decl : in out Iir; Main : Boolean) is Infos : Chap7.Implicit_Subprogram_Infos; + Subprg_Kind : Subprg_Translate_Kind; begin - -- Skip type declaration. pragma Assert (Get_Kind (Decl) in Iir_Kinds_Type_Declaration); + + if Main then + Subprg_Kind := Subprg_Translate_Spec_And_Body; + else + Subprg_Kind := Subprg_Translate_Only_Spec; + end if; + Chap3.Translate_Type_Subprograms (Decl, Subprg_Kind); + + -- Skip type declaration. Decl := Get_Chain (Decl); -- Implicit subprograms are immediately follow the type declaration. @@ -1988,22 +2008,22 @@ package body Translation is New_Array_Type (Std_Boolean_Type_Node, Ghdl_Index_Type); New_Type_Decl (Create_Identifier ("BOOLEAN_ARRAY"), Std_Boolean_Array_Type); - Translate_Type_Implicit_Subprograms (Decl); + Translate_Type_Implicit_Subprograms (Decl, Main); -- Second declaration: bit. pragma Assert (Decl = Bit_Type_Declaration); Chap4.Translate_Bool_Type_Declaration (Bit_Type_Declaration); - Translate_Type_Implicit_Subprograms (Decl); + Translate_Type_Implicit_Subprograms (Decl, Main); -- Nothing special for other declarations. while Decl /= Null_Iir loop case Get_Kind (Decl) is when Iir_Kind_Type_Declaration => Chap4.Translate_Type_Declaration (Decl); - Translate_Type_Implicit_Subprograms (Decl); + Translate_Type_Implicit_Subprograms (Decl, Main); when Iir_Kind_Anonymous_Type_Declaration => Chap4.Translate_Anonymous_Type_Declaration (Decl); - Translate_Type_Implicit_Subprograms (Decl); + Translate_Type_Implicit_Subprograms (Decl, Main); when Iir_Kind_Subtype_Declaration => Chap4.Translate_Subtype_Declaration (Decl); Decl := Get_Chain (Decl); @@ -2078,8 +2098,7 @@ package body Translation is --Pop_Global_Factory; end Translate_Standard; - procedure Finalize - is + procedure Finalize is begin Free_Node_Infos; Free_Old_Temp; |