diff options
author | Tristan Gingold <tgingold@free.fr> | 2014-12-13 07:34:11 +0100 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2014-12-13 07:34:11 +0100 |
commit | 687d32b88144d65f153eea439cbf9ce763c2d5c5 (patch) | |
tree | 2221af4f3cbcf0129744ebd7b63daf6abcf3900b /src | |
parent | 13adc95751db357e2060b16fee2baaa818743b91 (diff) | |
download | ghdl-687d32b88144d65f153eea439cbf9ce763c2d5c5.tar.gz ghdl-687d32b88144d65f153eea439cbf9ce763c2d5c5.tar.bz2 ghdl-687d32b88144d65f153eea439cbf9ce763c2d5c5.zip |
rtis: add source location for blocks and object. Use them in fst dumper.
Diffstat (limited to 'src')
-rw-r--r-- | src/grt/grt-avhpi.adb | 83 | ||||
-rw-r--r-- | src/grt/grt-avhpi.ads | 4 | ||||
-rw-r--r-- | src/grt/grt-disp_rti.adb | 29 | ||||
-rw-r--r-- | src/grt/grt-fst.adb | 51 | ||||
-rw-r--r-- | src/grt/grt-rtis.ads | 14 | ||||
-rw-r--r-- | src/grt/grt-rtis_addr.adb | 9 | ||||
-rw-r--r-- | src/grt/grt-signals.adb | 3 | ||||
-rw-r--r-- | src/vhdl/translate/trans-helpers2.adb | 2 | ||||
-rw-r--r-- | src/vhdl/translate/trans-rtis.adb | 124 | ||||
-rw-r--r-- | src/vhdl/translate/translation.adb | 5 |
10 files changed, 282 insertions, 42 deletions
diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb index 690a6bb8f..434e99938 100644 --- a/src/grt/grt-avhpi.adb +++ b/src/grt/grt-avhpi.adb @@ -551,6 +551,41 @@ package body Grt.Avhpi is procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; Obj : VhpiHandleT; + Res : out Ghdl_C_String) is + begin + Res := null; + + case Property is + when VhpiFileNameP => + declare + Parent : Ghdl_Rti_Access; + begin + Parent := Obj.Ctxt.Block; + while Parent /= null loop + case Parent.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture => + Res := + To_Ghdl_Rtin_Block_Filename_Acc (Parent).Filename; + return; + when Ghdl_Rtik_Block + | Ghdl_Rtik_Process => + Parent := + To_Ghdl_Rtin_Block_Acc (Parent).Parent; + when others => + return; + end case; + end loop; + end; + when others => + null; + end case; + end Vhpi_Get_Str; + + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; Res : out String; Len : out Natural) is @@ -747,6 +782,13 @@ package body Grt.Avhpi is when others => return; end case; + when VhpiCompInstStmtK => + Res := (Kind => VhpiArchBodyK, + Ctxt => Null_Context); + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + pragma Assert (Ref.Ctxt.Block.Kind = Ghdl_Rtik_Architecture); + Error := AvhpiErrorOk; + return; when others => return; end case; @@ -973,6 +1015,9 @@ package body Grt.Avhpi is Error : out AvhpiErrorT) is begin + -- Default error. + Error := AvhpiErrorNotImplemented; + case Property is when VhpiLeftBoundP => if Obj.Kind /= VhpiIntRangeK then @@ -985,9 +1030,9 @@ package body Grt.Avhpi is when Ghdl_Rtik_Type_I32 => Res := Obj.Rng_Addr.I32.Left; when others => - Error := AvhpiErrorNotImplemented; + null; end case; - return; + when VhpiRightBoundP => if Obj.Kind /= VhpiIntRangeK then Error := AvhpiErrorBadRel; @@ -998,11 +1043,39 @@ package body Grt.Avhpi is when Ghdl_Rtik_Type_I32 => Res := Obj.Rng_Addr.I32.Right; when others => - Error := AvhpiErrorNotImplemented; + null; end case; - return; + + when VhpiLineNoP => + declare + Linecol : Ghdl_Index_Type; + begin + case Obj.Kind is + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + -- Objects. + Linecol := Obj.Obj.Linecol; + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK => + -- Blocks. + Linecol := + To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Linecol; + when VhpiCompInstStmtK => + Linecol := Obj.Inst.Linecol; + when others => + return; + end case; + Res := VhpiIntT (Linecol / 256); + Error := AvhpiErrorOk; + end; + when others => - Error := AvhpiErrorNotImplemented; + null; end case; end Vhpi_Get; diff --git a/src/grt/grt-avhpi.ads b/src/grt/grt-avhpi.ads index e55a1d881..b61b1ff8a 100644 --- a/src/grt/grt-avhpi.ads +++ b/src/grt/grt-avhpi.ads @@ -443,6 +443,10 @@ package Grt.Avhpi is Res : out String; Len : out Natural); + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; + Res : out Ghdl_C_String); + subtype VhpiIntT is Ghdl_I32; procedure Vhpi_Get (Property : VhpiIntPropertyT; diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb index a8c2d9648..bb6f75ffb 100644 --- a/src/grt/grt-disp_rti.adb +++ b/src/grt/grt-disp_rti.adb @@ -624,6 +624,16 @@ package body Grt.Disp_Rti is end case; end Disp_Subtype_Indication; + procedure Disp_Linecol (Linecol : Ghdl_Index_Type) + is + Line : constant Ghdl_U32 := Ghdl_U32 (Linecol / 256); + Col : constant Ghdl_U32 := Ghdl_U32 (Linecol mod 256); + begin + Put ("sloc="); + Put_U32 (stdout, Line); + Put (":"); + Put_U32 (stdout, Col); + end Disp_Linecol; procedure Disp_Rti (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context; @@ -649,9 +659,24 @@ package body Grt.Disp_Rti is Disp_Indent (Indent); Disp_Kind (Blk.Common.Kind); Disp_Depth (Blk.Common.Depth); + Put (", "); + Disp_Linecol (Blk.Linecol); Put (": "); Disp_Name (Blk.Name); New_Line; + case Blk.Common.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture => + Disp_Indent (Indent); + Put (" filename: "); + Disp_Name (To_Ghdl_Rtin_Block_Filename_Acc + (To_Ghdl_Rti_Access (Blk)).Filename); + New_Line; + when others => + null; + end case; if Blk.Parent /= null then case Blk.Common.Kind is when Ghdl_Rtik_Architecture => @@ -708,6 +733,8 @@ package body Grt.Disp_Rti is Disp_Indent (Indent); Disp_Kind (Obj.Common.Kind); Disp_Depth (Obj.Common.Depth); + Put (", "); + Disp_Linecol (Obj.Linecol); Put ("; "); Disp_Name (Obj.Name); Put (": "); @@ -767,6 +794,8 @@ package body Grt.Disp_Rti is begin Disp_Indent (Indent); Disp_Kind (Inst.Common.Kind); + Put (", "); + Disp_Linecol (Inst.Linecol); Put (": "); Disp_Name (Inst.Name); New_Line; diff --git a/src/grt/grt-fst.adb b/src/grt/grt-fst.adb index a44a2630d..a290dd4f6 100644 --- a/src/grt/grt-fst.adb +++ b/src/grt/grt-fst.adb @@ -288,6 +288,21 @@ package body Grt.Fst is end; end if; + -- Source (for instances ?) + if Boolean'(False) then + declare + Filename : Ghdl_C_String; + Line : VhpiIntT; + begin + Vhpi_Get_Str (VhpiFileNameP, Sig, Filename); + Vhpi_Get (VhpiLineNoP, Sig, Line, Err); + if Filename /= null and then Err = AvhpiErrorOk then + fstWriterSetSourceStem + (Context, Filename, Interfaces.C.unsigned (Line), 0); + end if; + end; + end if; + -- Extract type name. Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Err); if Err /= AvhpiErrorOk then @@ -382,7 +397,43 @@ package body Grt.Fst is is Name : String (1 .. 128); Name_Len : Integer; + Err : AvhpiErrorT; begin + -- Source file and line. + declare + Filename : Ghdl_C_String; + Line : VhpiIntT; + Arch : VhpiHandleT; + begin + Vhpi_Get_Str (VhpiFileNameP, Decl, Filename); + Vhpi_Get (VhpiLineNoP, Decl, Line, Err); + if Filename /= null and then Err = AvhpiErrorOk then + if Vhpi_Get_Kind (Decl) /= VhpiCompInstStmtK then + -- For a block, a generate block: source location. + fstWriterSetSourceStem + (Context, Filename, Interfaces.C.unsigned (Line), 0); + else + -- For a component instantiation: instance location + fstWriterSetSourceInstantiationStem + (Context, Filename, Interfaces.C.unsigned (Line), 0); + -- Request DesignUnit => arch + Vhpi_Handle (VhpiDesignUnit, Decl, Arch, Err); + if Err /= AvhpiErrorOk then + Avhpi_Error (Err); + elsif Arch /= Null_Handle then + -- Request filename and line. + Vhpi_Get_Str (VhpiFileNameP, Arch, Filename); + Vhpi_Get (VhpiLineNoP, Arch, Line, Err); + if Filename /= null and then Err = AvhpiErrorOk then + -- And source location. + fstWriterSetSourceStem + (Context, Filename, Interfaces.C.unsigned (Line), 0); + end if; + end if; + end if; + end if; + end; + Vhpi_Get_Str (VhpiNameP, Decl, Name, Name_Len); if Name_Len < Name'Last then Name (Name_Len + 1) := NUL; diff --git a/src/grt/grt-rtis.ads b/src/grt/grt-rtis.ads index 6bb76597e..b5d307b25 100644 --- a/src/grt/grt-rtis.ads +++ b/src/grt/grt-rtis.ads @@ -125,6 +125,7 @@ package Grt.Rtis is Common : Ghdl_Rti_Common; Name : Ghdl_C_String; Loc : Ghdl_Rti_Loc; + Linecol : Ghdl_Index_Type; Parent : Ghdl_Rti_Access; Size : Ghdl_Index_Type; Nbr_Child : Ghdl_Index_Type; @@ -136,11 +137,20 @@ package Grt.Rtis is function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion (Source => Ghdl_Rtin_Block_Acc, Target => Ghdl_Rti_Access); + type Ghdl_Rtin_Block_Filename is record + Block : Ghdl_Rtin_Block; + Filename : Ghdl_C_String; + end record; + type Ghdl_Rtin_Block_Filename_Acc is access Ghdl_Rtin_Block_Filename; + function To_Ghdl_Rtin_Block_Filename_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Filename_Acc); + type Ghdl_Rtin_Object is record Common : Ghdl_Rti_Common; Name : Ghdl_C_String; Loc : Ghdl_Rti_Loc; Obj_Type : Ghdl_Rti_Access; + Linecol : Ghdl_Index_Type; end record; type Ghdl_Rtin_Object_Acc is access Ghdl_Rtin_Object; function To_Ghdl_Rtin_Object_Acc is new Ada.Unchecked_Conversion @@ -151,9 +161,10 @@ package Grt.Rtis is type Ghdl_Rtin_Instance is record Common : Ghdl_Rti_Common; Name : Ghdl_C_String; + Linecol : Ghdl_Index_Type; Loc : Ghdl_Rti_Loc; Parent : Ghdl_Rti_Access; - Instance : Ghdl_Rti_Access; + Instance : Ghdl_Rti_Access; -- Component or entity. end record; type Ghdl_Rtin_Instance_Acc is access Ghdl_Rtin_Instance; function To_Ghdl_Rtin_Instance_Acc is new Ada.Unchecked_Conversion @@ -348,6 +359,7 @@ package Grt.Rtis is (Common => (Ghdl_Rtik_Top, 0, 0, 0), Name => null, Loc => Null_Rti_Loc, + Linecol => 0, Parent => null, Size => 0, Nbr_Child => 0, diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb index 70a0e2118..d9f746e5b 100644 --- a/src/grt/grt-rtis_addr.adb +++ b/src/grt/grt-rtis_addr.adb @@ -187,15 +187,14 @@ package body Grt.Rtis_Addr is Ctxt : Rti_Context; Sub_Ctxt : out Rti_Context) is - Inst_Addr : Address; - Inst_Base : Address; - begin -- Address of the field containing the address of the instance. - Inst_Addr := Ctxt.Base + Inst.Loc; + Inst_Addr : constant Address := Ctxt.Base + Inst.Loc; -- Read sub instance address. - Inst_Base := To_Addr_Acc (Inst_Addr).all; + Inst_Base : constant Address := To_Addr_Acc (Inst_Addr).all; + begin -- Read instance RTI. if Inst_Base = Null_Address then + -- No instance. Sub_Ctxt := (Base => Null_Address, Block => null); else Sub_Ctxt := (Base => Inst_Base, diff --git a/src/grt/grt-signals.adb b/src/grt/grt-signals.adb index 9698d8178..2ec5aa2bf 100644 --- a/src/grt/grt-signals.adb +++ b/src/grt/grt-signals.adb @@ -1385,6 +1385,7 @@ package body Grt.Signals is Depth => 0, Mode => Ghdl_Rti_Signal_Mode_None, Max_Depth => 0), + Linecol => 0, Name => null, Loc => Null_Rti_Loc, Obj_Type => null); @@ -1394,6 +1395,7 @@ package body Grt.Signals is Depth => 0, Mode => Ghdl_Rti_Signal_Mode_None, Max_Depth => 0), + Linecol => 0, Name => null, Loc => Null_Rti_Loc, Obj_Type => null); @@ -1475,6 +1477,7 @@ package body Grt.Signals is Depth => 0, Mode => Ghdl_Rti_Signal_Mode_None, Max_Depth => 0), + Linecol => 0, Name => null, Loc => Null_Rti_Loc, Obj_Type => Std_Standard_Boolean_RTI_Ptr); diff --git a/src/vhdl/translate/trans-helpers2.adb b/src/vhdl/translate/trans-helpers2.adb index cf61883a7..c8da472c7 100644 --- a/src/vhdl/translate/trans-helpers2.adb +++ b/src/vhdl/translate/trans-helpers2.adb @@ -310,7 +310,7 @@ package body Trans.Helpers2 is begin New_Association (Assoc, New_Lit (New_Global_Address (Current_Filename_Node, - Char_Ptr_Type))); + Char_Ptr_Type))); New_Association (Assoc, New_Lit (New_Signed_Literal (Ghdl_I32_Type, Integer_64 (Line)))); end Assoc_Filename_Line; diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb index 1789050ef..0b804370a 100644 --- a/src/vhdl/translate/trans-rtis.adb +++ b/src/vhdl/translate/trans-rtis.adb @@ -17,6 +17,7 @@ -- 02111-1307, USA. with Name_Table; +with Files_Map; with Errorout; use Errorout; with Iirs_Utils; use Iirs_Utils; with Configuration; @@ -26,17 +27,22 @@ with Trans.Helpers2; use Trans.Helpers2; package body Trans.Rtis is - -- Node for package, body, entity, architecture, block, generate, - -- processes. + -- Node for block, generate, processes. Ghdl_Rtin_Block : O_Tnode; Ghdl_Rtin_Block_Common : O_Fnode; Ghdl_Rtin_Block_Name : O_Fnode; Ghdl_Rtin_Block_Loc : O_Fnode; + Ghdl_Rtin_Block_Linecol : O_Fnode; Ghdl_Rtin_Block_Parent : O_Fnode; Ghdl_Rtin_Block_Size : O_Fnode; Ghdl_Rtin_Block_Nbr_Child : O_Fnode; Ghdl_Rtin_Block_Children : O_Fnode; + -- A block with a filename: for package, body, entity and architecture. + Ghdl_Rtin_Block_File : O_Tnode; + Ghdl_Rtin_Block_File_Block : O_Fnode; + Ghdl_Rtin_Block_File_Filename : O_Fnode; + -- Node for scalar type decls. Ghdl_Rtin_Type_Scalar : O_Tnode; Ghdl_Rtin_Type_Scalar_Common : O_Fnode; @@ -121,14 +127,16 @@ package body Trans.Rtis is Ghdl_Rtin_Object_Name : O_Fnode; Ghdl_Rtin_Object_Loc : O_Fnode; Ghdl_Rtin_Object_Type : O_Fnode; + Ghdl_Rtin_Object_Linecol : O_Fnode; -- Node for an instance. - Ghdl_Rtin_Instance : O_Tnode; - Ghdl_Rtin_Instance_Common : O_Fnode; - Ghdl_Rtin_Instance_Name : O_Fnode; - Ghdl_Rtin_Instance_Loc : O_Fnode; - Ghdl_Rtin_Instance_Parent : O_Fnode; - Ghdl_Rtin_Instance_Type : O_Fnode; + Ghdl_Rtin_Instance : O_Tnode; + Ghdl_Rtin_Instance_Common : O_Fnode; + Ghdl_Rtin_Instance_Name : O_Fnode; + Ghdl_Rtin_Instance_Linecol : O_Fnode; + Ghdl_Rtin_Instance_Loc : O_Fnode; + Ghdl_Rtin_Instance_Parent : O_Fnode; + Ghdl_Rtin_Instance_Type : O_Fnode; -- Node for a component. Ghdl_Rtin_Component : O_Tnode; @@ -378,6 +386,8 @@ package body Trans.Rtis is Get_Identifier ("name"), Char_Ptr_Type); New_Record_Field (Constr, Ghdl_Rtin_Block_Loc, Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Linecol, + Get_Identifier ("linecol"), Ghdl_Index_Type); New_Record_Field (Constr, Ghdl_Rtin_Block_Parent, Wki_Parent, Ghdl_Rti_Access); New_Record_Field (Constr, Ghdl_Rtin_Block_Size, @@ -391,6 +401,20 @@ package body Trans.Rtis is Ghdl_Rtin_Block); end; + -- Create type ghdl_rtin_block_file + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Block_File_Block, + Get_Identifier ("block"), Ghdl_Rtin_Block); + New_Record_Field (Constr, Ghdl_Rtin_Block_File_Filename, + Get_Identifier ("filename"), Char_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Block_File); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_block_file"), + Ghdl_Rtin_Block_File); + end; + -- type (type and subtype declarations). declare Constr : O_Element_List; @@ -601,6 +625,8 @@ package body Trans.Rtis is Get_Identifier ("loc"), Ghdl_Ptr_Type); New_Record_Field (Constr, Ghdl_Rtin_Object_Type, Get_Identifier ("obj_type"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Object_Linecol, + Get_Identifier ("linecol"), Ghdl_Index_Type); Finish_Record_Type (Constr, Ghdl_Rtin_Object); New_Type_Decl (Get_Identifier ("__ghdl_rtin_object"), Ghdl_Rtin_Object); @@ -615,6 +641,8 @@ package body Trans.Rtis is Get_Identifier ("common"), Ghdl_Rti_Common); New_Record_Field (Constr, Ghdl_Rtin_Instance_Name, Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Linecol, + Get_Identifier ("linecol"), Ghdl_Index_Type); New_Record_Field (Constr, Ghdl_Rtin_Instance_Loc, Get_Identifier ("loc"), Ghdl_Ptr_Type); New_Record_Field (Constr, Ghdl_Rtin_Instance_Parent, @@ -791,7 +819,7 @@ package body Trans.Rtis is function Generate_Common (Kind : O_Cnode; Var : Var_Type := Null_Var; Mode : Natural := 0) - return O_Cnode + return O_Cnode is List : O_Record_Aggr_List; Res : O_Cnode; @@ -809,11 +837,11 @@ package body Trans.Rtis is end Generate_Common; -- Same as Generat_Common but for types. - function Generate_Common_Type (Kind : O_Cnode; - Depth : Rti_Depth_Type; + function Generate_Common_Type (Kind : O_Cnode; + Depth : Rti_Depth_Type; Max_Depth : Rti_Depth_Type; - Mode : Natural := 0) - return O_Cnode + Mode : Natural := 0) + return O_Cnode is List : O_Record_Aggr_List; Res : O_Cnode; @@ -1685,6 +1713,21 @@ package body Trans.Rtis is Global_Storage, Ghdl_Rtin_Object); end Generate_Signal_Rti; + function Generate_Linecol (Decl : Iir) return O_Cnode + is + Line : Natural; + Col : Natural; + Name : Name_Id; + begin + Files_Map.Location_To_Position (Get_Location (Decl), Name, Line, Col); + + -- Saturate col and line. + Col := Natural'Min (Col, 255); + Line := Natural'Min (Line, 2**24 - 1); + return Helpers.New_Index_Lit + (Unsigned_64 (Line) * 256 + Unsigned_64 (Col)); + end Generate_Linecol; + procedure Generate_Object (Decl : Iir; Rti : in out O_Dnode) is Decl_Type : Iir; @@ -1818,6 +1861,7 @@ package body Trans.Rtis is end if; New_Record_Aggr_El (List, Val); New_Record_Aggr_El (List, New_Rti_Address (Type_Info.Type_Rti)); + New_Record_Aggr_El (List, Generate_Linecol (Decl)); Finish_Record_Aggr (List, Val); Finish_Const_Value (Rti, Val); end if; @@ -1971,11 +2015,12 @@ package body Trans.Rtis is 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, Generate_Linecol (Stmt)); New_Record_Aggr_El (List, New_Offsetof (Get_Scope_Type - (Get_Info (Get_Parent (Stmt)).Block_Scope), - Info.Block_Link_Field, - Ghdl_Ptr_Type)); + (Get_Info (Get_Parent (Stmt)).Block_Scope), + Info.Block_Link_Field, + Ghdl_Ptr_Type)); New_Record_Aggr_El (List, New_Rti_Address (Parent)); if Is_Component_Instantiation (Stmt) then Val := New_Rti_Address @@ -2145,7 +2190,9 @@ package body Trans.Rtis is Name : O_Dnode; Arr : O_Dnode; List : O_Record_Aggr_List; + List_File : O_Record_Aggr_List; + Rti_Type : O_Tnode; Rti : O_Dnode; Kind : O_Cnode; @@ -2160,13 +2207,12 @@ package body Trans.Rtis is -- The type of a generator iterator is elaborated in the parent. if Get_Kind (Blk) = Iir_Kind_Generate_Statement then declare - Scheme : Iir; + Scheme : constant Iir := Get_Generation_Scheme (Blk); Iter_Type : Iir; Type_Info : Type_Info_Acc; Mark : Id_Mark_Type; Tmp : O_Dnode; begin - Scheme := Get_Generation_Scheme (Blk); if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then Iter_Type := Get_Type (Scheme); Type_Info := Get_Info (Iter_Type); @@ -2180,8 +2226,14 @@ package body Trans.Rtis is end; end if; + if Get_Kind (Get_Parent (Blk)) = Iir_Kind_Design_Unit then + Rti_Type := Ghdl_Rtin_Block_File; + else + Rti_Type := Ghdl_Rtin_Block; + end if; + New_Const_Decl (Rti, Create_Identifier ("RTI"), - O_Storage_Public, Ghdl_Rtin_Block); + O_Storage_Public, Rti_Type); Push_Rti_Node (Prev); Field_Off := O_Cnode_Null; @@ -2270,6 +2322,11 @@ package body Trans.Rtis is Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); Start_Const_Value (Rti); + + if Rti_Type = Ghdl_Rtin_Block_File then + Start_Record_Aggr (List_File, Rti_Type); + end if; + 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)); @@ -2277,6 +2334,7 @@ package body Trans.Rtis is Field_Off := Get_Null_Loc; end if; New_Record_Aggr_El (List, Field_Off); + New_Record_Aggr_El (List, Generate_Linecol (Blk)); if Parent_Rti = O_Dnode_Null then Res := New_Null_Access (Ghdl_Rti_Access); else @@ -2294,6 +2352,15 @@ package body Trans.Rtis is Unsigned_64 (Cur_Block.Nbr))); New_Record_Aggr_El (List, New_Global_Address (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)); + Finish_Record_Aggr (List_File, Res); + end if; + Finish_Const_Value (Rti, Res); Pop_Rti_Node (Prev); @@ -2342,6 +2409,7 @@ package body Trans.Rtis is begin Info := Get_Info (Lib); if Info /= null then + -- Already generated. return; end if; Info := Add_Info (Lib, Kind_Library); @@ -2378,13 +2446,13 @@ package body Trans.Rtis is procedure Generate_Unit (Lib_Unit : Iir) is + Info : constant Ortho_Info_Acc := Get_Info (Lib_Unit); Rti : O_Dnode; - Info : Ortho_Info_Acc; Mark : Id_Mark_Type; begin - Info := Get_Info (Lib_Unit); case Get_Kind (Lib_Unit) is when Iir_Kind_Configuration_Declaration => + -- No RTI for configurations. return; when Iir_Kind_Architecture_Body => if Info.Block_Rti_Const /= O_Dnode_Null then @@ -2427,10 +2495,12 @@ package body Trans.Rtis is null; end case; else + -- Compute parent RTI. case Get_Kind (Lib_Unit) is when Iir_Kind_Package_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Configuration_Declaration => + -- The library. declare Lib : Iir_Library_Declaration; begin @@ -2440,12 +2510,16 @@ package body Trans.Rtis is Rti := Get_Info (Lib).Library_Rti_Const; end; when Iir_Kind_Package_Body => + -- The package spec. Rti := Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const; when Iir_Kind_Architecture_Body => + -- The entity. Rti := Get_Info (Get_Entity (Lib_Unit)).Block_Rti_Const; when others => raise Internal_Error; end case; + + -- Generate RTI for Lib_Unit, using parent RTI. Generate_Block (Lib_Unit, Rti); end if; @@ -2473,8 +2547,7 @@ package body Trans.Rtis is Lib := Get_Library (Get_Design_File (Unit)); Generate_Library (Lib, True); - if Get_Kind (Get_Library_Unit (Unit)) - = Iir_Kind_Package_Declaration + if Get_Kind (Get_Library_Unit (Unit)) = Iir_Kind_Package_Declaration then Nbr_Pkgs := Nbr_Pkgs + 1; end if; @@ -2485,12 +2558,9 @@ package body Trans.Rtis is function Get_Context_Rti (Node : Iir) return O_Cnode is - Node_Info : Ortho_Info_Acc; - + Node_Info : constant Ortho_Info_Acc := Get_Info (Node); Rti_Const : O_Dnode; begin - Node_Info := Get_Info (Node); - case Get_Kind (Node) is when Iir_Kind_Component_Declaration => Rti_Const := Node_Info.Comp_Rti_Const; diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 2d89a62e1..b20f62218 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -199,9 +199,8 @@ package body Translation is is Info : Design_File_Info_Acc; begin - if Current_Filename_Node /= O_Dnode_Null then - raise Internal_Error; - end if; + pragma Assert (Current_Filename_Node = O_Dnode_Null); + Info := Get_Info (Design_File); if Info = null then Info := Add_Info (Design_File, Kind_Design_File); |