diff options
Diffstat (limited to 'src/ortho/mcode/ortho_code-dwarf.adb')
| -rw-r--r-- | src/ortho/mcode/ortho_code-dwarf.adb | 1351 |
1 files changed, 1351 insertions, 0 deletions
diff --git a/src/ortho/mcode/ortho_code-dwarf.adb b/src/ortho/mcode/ortho_code-dwarf.adb new file mode 100644 index 000000000..ad67d1ff6 --- /dev/null +++ b/src/ortho/mcode/ortho_code-dwarf.adb @@ -0,0 +1,1351 @@ +-- Mcode back-end for ortho - Dwarf generator. +-- Copyright (C) 2006 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.Directory_Operations; +with GNAT.Table; +with Interfaces; use Interfaces; +with Binary_File; use Binary_File; +with Dwarf; use Dwarf; +with Ada.Text_IO; +with Ortho_Code.Decls; +with Ortho_Code.Types; +with Ortho_Code.Consts; +with Ortho_Code.Flags; +with Ortho_Ident; +with Ortho_Code.Binary; + +package body Ortho_Code.Dwarf is + -- Dwarf debugging format. + -- Debugging. + Line1_Sect : Section_Acc := null; + Line_Last : Int32 := 0; + Line_Pc : Pc_Type := 0; + + -- Constant. + Min_Insn_Len : constant := 1; + Line_Base : constant := 1; + Line_Range : constant := 4; + Line_Opcode_Base : constant := 13; + Line_Max_Addr : constant := (255 - Line_Opcode_Base) / Line_Range; + -- + Line_Base; + + Cur_File : Natural := 0; + Last_File : Natural := 0; + + Orig_Sym : Symbol; + End_Sym : Symbol; + Abbrev_Sym : Symbol; + Info_Sym : Symbol; + Line_Sym : Symbol; + + Line_Sect : Section_Acc; + Abbrev_Sect : Section_Acc; + Info_Sect : Section_Acc; + Aranges_Sect : Section_Acc; + + Abbrev_Last : Unsigned_32; + +-- procedure Gen_String (Str : String) +-- is +-- begin +-- for I in Str'Range loop +-- Gen_B8 (Character'Pos (Str (I))); +-- end loop; +-- end Gen_String; + + procedure Gen_String_Nul (Str : String) + is + begin + Prealloc (Str'Length + 1); + for I in Str'Range loop + Gen_B8 (Character'Pos (Str (I))); + end loop; + Gen_B8 (0); + end Gen_String_Nul; + + procedure Gen_Sleb128 (V : Int32) + is + V1 : Uns32 := To_Uns32 (V); + V2 : Uns32; + B : Byte; + function Shift_Right_Arithmetic (Value : Uns32; Amount : Natural) + return Uns32; + pragma Import (Intrinsic, Shift_Right_Arithmetic); + begin + loop + B := Byte (V1 and 16#7F#); + V2 := Shift_Right_Arithmetic (V1, 7); + if (V2 = 0 and (B and 16#40#) = 0) + or (V2 = -1 and (B and 16#40#) /= 0) + then + Gen_B8 (B); + exit; + else + Gen_B8 (B or 16#80#); + V1 := V2; + end if; + end loop; + end Gen_Sleb128; + + procedure Gen_Uleb128 (V : Unsigned_32) + is + V1 : Unsigned_32 := V; + B : Byte; + begin + loop + B := Byte (V1 and 16#7f#); + V1 := Shift_Right (V1, 7); + if V1 /= 0 then + Gen_B8 (B or 16#80#); + else + Gen_B8 (B); + exit; + end if; + end loop; + end Gen_Uleb128; + +-- procedure New_Debug_Line_Decl (Line : Int32) +-- is +-- begin +-- Line_Last := Line; +-- end New_Debug_Line_Decl; + + procedure Set_Line_Stmt (Line : Int32) + is + Pc : Pc_Type; + D_Pc : Pc_Type; + D_Ln : Int32; + begin + if Line = Line_Last then + return; + end if; + Pc := Get_Current_Pc; + + D_Pc := (Pc - Line_Pc) / Min_Insn_Len; + D_Ln := Line - Line_Last; + + -- Always emit line information, since missing info can distrub the + -- user. + -- As an optimization, we could try to emit the highest line for the + -- same PC, since GDB seems to handle this way. + if False and D_Pc = 0 then + return; + end if; + + Set_Current_Section (Line1_Sect); + Prealloc (32); + + if Cur_File /= Last_File then + Gen_B8 (Byte (DW_LNS_Set_File)); + Gen_Uleb128 (Unsigned_32 (Cur_File)); + Last_File := Cur_File; + elsif Cur_File = 0 then + return; + end if; + + if D_Ln < Line_Base or D_Ln >= (Line_Base + Line_Range) then + -- Emit an advance line. + Gen_B8 (Byte (DW_LNS_Advance_Line)); + Gen_Sleb128 (Int32 (D_Ln - Line_Base)); + D_Ln := Line_Base; + end if; + if D_Pc >= Line_Max_Addr then + -- Emit an advance addr. + Gen_B8 (Byte (DW_LNS_Advance_Pc)); + Gen_Uleb128 (Unsigned_32 (D_Pc)); + D_Pc := 0; + end if; + Gen_B8 (Line_Opcode_Base + + Byte (D_Pc) * Line_Range + + Byte (D_Ln - Line_Base)); + + --Set_Current_Section (Text_Sect); + Line_Pc := Pc; + Line_Last := Line; + end Set_Line_Stmt; + + + type String_Acc is access constant String; + + type Dir_Chain; + type Dir_Chain_Acc is access Dir_Chain; + type Dir_Chain is record + Name : String_Acc; + Next : Dir_Chain_Acc; + end record; + + type File_Chain; + type File_Chain_Acc is access File_Chain; + type File_Chain is record + Name : String_Acc; + Dir : Natural; + Next : File_Chain_Acc; + end record; + + Dirs : Dir_Chain_Acc := null; + Files : File_Chain_Acc := null; + + procedure Set_Filename (Dir : String; File : String) + is + D : Natural; + F : Natural; + D_C : Dir_Chain_Acc; + F_C : File_Chain_Acc; + begin + -- Find directory. + if Dir = "" then + -- Current directory. + D := 0; + elsif Dirs = null then + -- First directory. + Dirs := new Dir_Chain'(Name => new String'(Dir), + Next => null); + D := 1; + else + -- Find a directory. + D_C := Dirs; + D := 1; + loop + exit when D_C.Name.all = Dir; + D := D + 1; + if D_C.Next = null then + D_C.Next := new Dir_Chain'(Name => new String'(Dir), + Next => null); + exit; + else + D_C := D_C.Next; + end if; + end loop; + end if; + + -- Find file. + F := 1; + if Files = null then + -- first file. + Files := new File_Chain'(Name => new String'(File), + Dir => D, + Next => null); + else + F_C := Files; + loop + exit when F_C.Name.all = File and F_C.Dir = D; + F := F + 1; + if F_C.Next = null then + F_C.Next := new File_Chain'(Name => new String'(File), + Dir => D, + Next => null); + exit; + else + F_C := F_C.Next; + end if; + end loop; + end if; + Cur_File := F; + end Set_Filename; + + procedure Gen_Abbrev_Header (Tag : Unsigned_32; Child : Byte) is + begin + Gen_Uleb128 (Tag); + Gen_B8 (Child); + end Gen_Abbrev_Header; + + procedure Gen_Abbrev_Tuple (Attr : Unsigned_32; Form : Unsigned_32) is + begin + Gen_Uleb128 (Attr); + Gen_Uleb128 (Form); + end Gen_Abbrev_Tuple; + + procedure Init + is + begin + -- Generate type names. + Flags.Flag_Type_Name := True; + + + Orig_Sym := Create_Local_Symbol; + Set_Symbol_Pc (Orig_Sym, False); + End_Sym := Create_Local_Symbol; + + Create_Section (Line1_Sect, ".debug_line-1", Section_Debug); + Set_Current_Section (Line1_Sect); + + -- Write Address. + Gen_B8 (0); -- extended opcode + Gen_B8 (5); -- length: 1 + 4 + Gen_B8 (Byte (DW_LNE_Set_Address)); + Gen_Ua_32 (Orig_Sym, 0); + + Line_Last := 1; + + Create_Section (Line_Sect, ".debug_line", Section_Debug); + Set_Section_Info (Line_Sect, null, 0, 0); + Set_Current_Section (Line_Sect); + Line_Sym := Create_Local_Symbol; + Set_Symbol_Pc (Line_Sym, False); + + -- Abbrevs. + Create_Section (Abbrev_Sect, ".debug_abbrev", Section_Debug); + Set_Section_Info (Abbrev_Sect, null, 0, 0); + Set_Current_Section (Abbrev_Sect); + + Abbrev_Sym := Create_Local_Symbol; + Set_Symbol_Pc (Abbrev_Sym, False); + + Gen_Uleb128 (1); + Gen_Abbrev_Header (DW_TAG_Compile_Unit, DW_CHILDREN_Yes); + + Gen_Abbrev_Tuple (DW_AT_Stmt_List, DW_FORM_Data4); + Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (DW_AT_Producer, DW_FORM_String); + Gen_Abbrev_Tuple (DW_AT_Comp_Dir, DW_FORM_String); + Gen_Abbrev_Tuple (0, 0); + + Abbrev_Last := 1; + + -- Info. + Create_Section (Info_Sect, ".debug_info", Section_Debug); + Set_Section_Info (Info_Sect, null, 0, 0); + Set_Current_Section (Info_Sect); + Info_Sym := Create_Local_Symbol; + Set_Symbol_Pc (Info_Sym, False); + + Gen_32 (7); -- Length: to be patched. + Gen_16 (2); -- version + Gen_Ua_32 (Abbrev_Sym, 0); -- Abbrev offset + Gen_B8 (4); -- Ptr size. + + -- Compile_unit. + Gen_Uleb128 (1); + Gen_Ua_32 (Line_Sym, 0); + Gen_Ua_32 (Orig_Sym, 0); + Gen_Ua_32 (End_Sym, 0); + Gen_String_Nul ("T.Gingold ortho_mcode (2004)"); + Gen_String_Nul (GNAT.Directory_Operations.Get_Current_Dir); + end Init; + + procedure Emit_Decl (Decl : O_Dnode); + + -- Next node to be emitted. + Last_Decl : O_Dnode := O_Dnode_First; + + procedure Emit_Decls_Until (Last : O_Dnode) + is + use Ortho_Code.Decls; + begin + while Last_Decl < Last loop + Emit_Decl (Last_Decl); + Last_Decl := Get_Decl_Chain (Last_Decl); + end loop; + end Emit_Decls_Until; + + procedure Finish + is + Length : Pc_Type; + Last : O_Dnode; + begin + Set_Symbol_Pc (End_Sym, False); + Length := Get_Current_Pc; + + Last := Decls.Get_Decl_Last; + Emit_Decls_Until (Last); + if Last_Decl <= Last then + Emit_Decl (Last); + end if; + + -- Finish abbrevs. + Set_Current_Section (Abbrev_Sect); + Gen_Uleb128 (0); + + -- Emit header. + Set_Current_Section (Line_Sect); + + -- Unit_Length (to be patched). + Gen_32 (0); + -- version + Gen_16 (2); + -- header_length (to be patched). + Gen_32 (5 + 12 + 1); + -- minimum_instruction_length. + Gen_B8 (Min_Insn_Len); + -- default_is_stmt + Gen_B8 (1); + -- line base + Gen_B8 (Line_Base); + -- line range + Gen_B8 (Line_Range); + -- opcode base + Gen_B8 (Line_Opcode_Base); + -- standard_opcode_length. + Gen_B8 (0); -- copy + Gen_B8 (1); -- advance pc + Gen_B8 (1); -- advance line + Gen_B8 (1); -- set file + Gen_B8 (1); -- set column + Gen_B8 (0); -- negate stmt + Gen_B8 (0); -- set basic block + Gen_B8 (0); -- const add pc + Gen_B8 (1); -- fixed advance pc + Gen_B8 (0); -- set prologue end + Gen_B8 (0); -- set epilogue begin + Gen_B8 (1); -- set isa + --if Line_Opcode_Base /= 13 then + -- raise Program_Error; + --end if; + + -- include directories + declare + D : Dir_Chain_Acc; + begin + D := Dirs; + while D /= null loop + Gen_String_Nul (D.Name.all); + D := D.Next; + end loop; + Gen_B8 (0); -- last entry. + end; + + -- file_names. + declare + F : File_Chain_Acc; + begin + F := Files; + while F /= null loop + Gen_String_Nul (F.Name.all); + Gen_Uleb128 (Unsigned_32 (F.Dir)); + Gen_B8 (0); -- time + Gen_B8 (0); -- length + F := F.Next; + end loop; + Gen_B8 (0); -- last entry. + end; + + -- Set prolog length + Patch_32 (6, Unsigned_32 (Get_Current_Pc - 6)); + + Merge_Section (Line_Sect, Line1_Sect); + + -- Emit end of sequence. + Gen_B8 (0); -- extended opcode + Gen_B8 (1); -- length: 1 + Gen_B8 (Byte (DW_LNE_End_Sequence)); + + -- Set total length. + Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4)); + + -- Info. + Set_Current_Section (Info_Sect); + -- Finish child. + Gen_Uleb128 (0); + -- Set total length. + Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4)); + + -- Aranges + Create_Section (Aranges_Sect, ".debug_aranges", Section_Debug); + Set_Section_Info (Aranges_Sect, null, 0, 0); + Set_Current_Section (Aranges_Sect); + + Gen_32 (28); -- Length. + Gen_16 (2); -- version + Gen_Ua_32 (Info_Sym, 0); -- info offset + Gen_B8 (4); -- Ptr size. + Gen_B8 (0); -- seg desc size. + Gen_32 (0); -- pad + Gen_Ua_32 (Orig_Sym, 0); -- text offset + Gen_32 (Unsigned_32 (Length)); + Gen_32 (0); -- End + Gen_32 (0); + end Finish; + + procedure Generate_Abbrev (Abbrev : out Unsigned_32) is + begin + Abbrev_Last := Abbrev_Last + 1; + Abbrev := Abbrev_Last; + + Set_Current_Section (Abbrev_Sect); + -- FIXME: should be enough ? + Prealloc (128); + Gen_Uleb128 (Abbrev); + end Generate_Abbrev; + + procedure Gen_Info_Header (Abbrev : Unsigned_32) is + begin + Set_Current_Section (Info_Sect); + Gen_Uleb128 (Abbrev); + end Gen_Info_Header; + + function Gen_Info_Sibling return Pc_Type + is + Pc : Pc_Type; + begin + Pc := Get_Current_Pc; + Gen_32 (0); + return Pc; + end Gen_Info_Sibling; + + procedure Patch_Info_Sibling (Pc : Pc_Type) is + begin + Patch_32 (Pc, Unsigned_32 (Get_Current_Pc)); + end Patch_Info_Sibling; + + Abbrev_Base_Type : Unsigned_32 := 0; + Abbrev_Base_Type_Name : Unsigned_32 := 0; + Abbrev_Pointer : Unsigned_32 := 0; + Abbrev_Pointer_Name : Unsigned_32 := 0; + Abbrev_Uncomplete_Pointer : Unsigned_32 := 0; + Abbrev_Uncomplete_Pointer_Name : Unsigned_32 := 0; + Abbrev_Ucarray : Unsigned_32 := 0; + Abbrev_Ucarray_Name : Unsigned_32 := 0; + Abbrev_Uc_Subrange : Unsigned_32 := 0; + Abbrev_Subarray : Unsigned_32 := 0; + Abbrev_Subarray_Name : Unsigned_32 := 0; + Abbrev_Subrange : Unsigned_32 := 0; + Abbrev_Struct : Unsigned_32 := 0; + Abbrev_Struct_Name : Unsigned_32 := 0; + Abbrev_Union : Unsigned_32 := 0; + Abbrev_Union_Name : Unsigned_32 := 0; + Abbrev_Member : Unsigned_32 := 0; + Abbrev_Enum : Unsigned_32 := 0; + Abbrev_Enum_Name : Unsigned_32 := 0; + Abbrev_Enumerator : Unsigned_32 := 0; + + package TOnodes is new GNAT.Table + (Table_Component_Type => Pc_Type, + Table_Index_Type => O_Tnode, + Table_Low_Bound => O_Tnode_First, + Table_Initial => 16, + Table_Increment => 100); + + procedure Emit_Type_Ref (Atype : O_Tnode) + is + Off : Pc_Type; + begin + Off := TOnodes.Table (Atype); + if Off = Null_Pc then + raise Program_Error; + end if; + Gen_32 (Unsigned_32 (Off)); + end Emit_Type_Ref; + + procedure Emit_Ident (Id : O_Ident) + is + use Ortho_Ident; + L : Natural; + begin + L := Get_String_Length (Id); + Prealloc (Pc_Type (L) + 128); + Gen_String_Nul (Get_String (Id)); + end Emit_Ident; + + procedure Add_Type_Ref (Atype : O_Tnode; Pc : Pc_Type) + is + Prev : O_Tnode; + begin + if Atype > TOnodes.Last then + -- Expand. + Prev := TOnodes.Last; + TOnodes.Set_Last (Atype); + TOnodes.Table (Prev + 1 .. Atype - 1) := (others => Null_Pc); + end if; + TOnodes.Table (Atype) := Pc; + end Add_Type_Ref; + + procedure Emit_Decl_Ident (Decl : O_Dnode) + is + use Ortho_Code.Decls; + begin + Emit_Ident (Get_Decl_Ident (Decl)); + end Emit_Decl_Ident; + + procedure Emit_Decl_Ident_If_Set (Decl : O_Dnode) + is + use Ortho_Code.Decls; + begin + if Decl /= O_Dnode_Null then + Emit_Ident (Get_Decl_Ident (Decl)); + end if; + end Emit_Decl_Ident_If_Set; + + procedure Emit_Type (Atype : O_Tnode); + + procedure Emit_Base_Type (Atype : O_Tnode; Decl : O_Dnode) + is + use Ortho_Code.Types; + procedure Finish_Gen_Abbrev is + begin + Gen_Abbrev_Tuple (DW_AT_Encoding, DW_FORM_Data1); + Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); + Gen_Abbrev_Tuple (0, 0); + end Finish_Gen_Abbrev; + begin + if Decl = O_Dnode_Null then + if Abbrev_Base_Type = 0 then + Generate_Abbrev (Abbrev_Base_Type); + Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Base_Type); + else + if Abbrev_Base_Type_Name = 0 then + Generate_Abbrev (Abbrev_Base_Type_Name); + Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Base_Type_Name); + Emit_Decl_Ident (Decl); + end if; + + case Get_Type_Kind (Atype) is + when OT_Signed => + Gen_B8 (DW_ATE_Signed); + when OT_Unsigned => + Gen_B8 (DW_ATE_Unsigned); + when OT_Float => + Gen_B8 (DW_ATE_Float); + when others => + raise Program_Error; + end case; + Gen_B8 (Byte (Get_Type_Size (Atype))); + end Emit_Base_Type; + + procedure Emit_Access_Type (Atype : O_Tnode; Decl : O_Dnode) + is + use Ortho_Code.Types; + procedure Finish_Gen_Abbrev is + begin + Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (0, 0); + end Finish_Gen_Abbrev; + + procedure Finish_Gen_Abbrev_Uncomplete is + begin + Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); + Gen_Abbrev_Tuple (0, 0); + end Finish_Gen_Abbrev_Uncomplete; + + Dtype : O_Tnode; + D_Pc : Pc_Type; + begin + Dtype := Get_Type_Access_Type (Atype); + + if Dtype = O_Tnode_Null then + if Decl = O_Dnode_Null then + if Abbrev_Uncomplete_Pointer = 0 then + Generate_Abbrev (Abbrev_Uncomplete_Pointer); + Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); + Finish_Gen_Abbrev_Uncomplete; + end if; + Gen_Info_Header (Abbrev_Uncomplete_Pointer); + else + if Abbrev_Uncomplete_Pointer_Name = 0 then + Generate_Abbrev (Abbrev_Uncomplete_Pointer_Name); + Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Finish_Gen_Abbrev_Uncomplete; + end if; + Gen_Info_Header (Abbrev_Uncomplete_Pointer_Name); + Emit_Decl_Ident (Decl); + end if; + Gen_B8 (Byte (Get_Type_Size (Atype))); + else + if Decl = O_Dnode_Null then + if Abbrev_Pointer = 0 then + Generate_Abbrev (Abbrev_Pointer); + Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Pointer); + else + if Abbrev_Pointer_Name = 0 then + Generate_Abbrev (Abbrev_Pointer_Name); + Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Pointer_Name); + Emit_Decl_Ident (Decl); + end if; + Gen_B8 (Byte (Get_Type_Size (Atype))); + -- Break possible loops: generate the access entry... + D_Pc := Get_Current_Pc; + Gen_32 (0); + -- ... generate the designated type ... + Emit_Type (Dtype); + -- ... and write its reference. + Patch_32 (D_Pc, Unsigned_32 (TOnodes.Table (Dtype))); + end if; + end Emit_Access_Type; + + procedure Emit_Ucarray_Type (Atype : O_Tnode; Decl : O_Dnode) + is + use Ortho_Code.Types; + + procedure Finish_Gen_Abbrev is + begin + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (0, 0); + end Finish_Gen_Abbrev; + begin + if Decl = O_Dnode_Null then + if Abbrev_Ucarray = 0 then + Generate_Abbrev (Abbrev_Ucarray); + Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Ucarray); + else + if Abbrev_Ucarray_Name = 0 then + Generate_Abbrev (Abbrev_Ucarray_Name); + Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Ucarray_Name); + Emit_Decl_Ident (Decl); + end if; + Emit_Type_Ref (Get_Type_Ucarray_Element (Atype)); + + if Abbrev_Uc_Subrange = 0 then + Generate_Abbrev (Abbrev_Uc_Subrange); + Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No); + + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (0, 0); + end if; + + Gen_Info_Header (Abbrev_Uc_Subrange); + Emit_Type_Ref (Get_Type_Ucarray_Index (Atype)); + + Gen_Uleb128 (0); + end Emit_Ucarray_Type; + + procedure Emit_Subarray_Type (Atype : O_Tnode; Decl : O_Dnode) + is + use Ortho_Code.Types; + procedure Finish_Gen_Abbrev is + begin + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); + Gen_Abbrev_Tuple (0, 0); + end Finish_Gen_Abbrev; + + Base : O_Tnode; + begin + if Decl = O_Dnode_Null then + if Abbrev_Subarray = 0 then + Generate_Abbrev (Abbrev_Subarray); + Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Subarray); + else + if Abbrev_Subarray_Name = 0 then + Generate_Abbrev (Abbrev_Subarray_Name); + Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Subarray_Name); + Emit_Decl_Ident (Decl); + end if; + + Base := Get_Type_Subarray_Base (Atype); + + Emit_Type_Ref (Get_Type_Ucarray_Element (Base)); + Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype))); + + if Abbrev_Subrange = 0 then + Generate_Abbrev (Abbrev_Subrange); + Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No); + + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Lower_Bound, DW_FORM_Data1); + Gen_Abbrev_Tuple (DW_AT_Count, DW_FORM_Udata); + Gen_Abbrev_Tuple (0, 0); + end if; + + Gen_Info_Header (Abbrev_Subrange); + Emit_Type_Ref (Get_Type_Ucarray_Index (Base)); + Gen_B8 (0); + Gen_Uleb128 (Unsigned_32 (Get_Type_Subarray_Length (Atype))); + + Gen_Uleb128 (0); + end Emit_Subarray_Type; + + procedure Emit_Members (Atype : O_Tnode; Decl : O_Dnode) + is + use Ortho_Code.Types; + Nbr : Uns32; + F : O_Fnode; + Loc_Pc : Pc_Type; + Sibling_Pc : Pc_Type; + begin + if Abbrev_Member = 0 then + Generate_Abbrev (Abbrev_Member); + + Gen_Abbrev_Header (DW_TAG_Member, DW_CHILDREN_No); + + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Data_Member_Location, DW_FORM_Block1); + Gen_Abbrev_Tuple (0, 0); + end if; + + Set_Current_Section (Info_Sect); + Sibling_Pc := Gen_Info_Sibling; + Emit_Decl_Ident_If_Set (Decl); + Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype))); + + Nbr := Get_Type_Record_Nbr_Fields (Atype); + F := Get_Type_Record_Fields (Atype); + while Nbr > 0 loop + Gen_Uleb128 (Abbrev_Member); + Emit_Ident (Get_Field_Ident (F)); + Emit_Type_Ref (Get_Field_Type (F)); + + -- Location. + Loc_Pc := Get_Current_Pc; + Gen_B8 (3); + Gen_B8 (DW_OP_Plus_Uconst); + Gen_Uleb128 (Unsigned_32 (Get_Field_Offset (F))); + Patch_B8 (Loc_Pc, Unsigned_8 (Get_Current_Pc - (Loc_Pc + 1))); + + F := Get_Field_Chain (F); + Nbr := Nbr - 1; + end loop; + + -- end of children. + Gen_Uleb128 (0); + Patch_Info_Sibling (Sibling_Pc); + end Emit_Members; + + procedure Emit_Record_Type (Atype : O_Tnode; Decl : O_Dnode) + is + use Ortho_Code.Types; + procedure Finish_Gen_Abbrev is + begin + Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); + Gen_Abbrev_Tuple (0, 0); + end Finish_Gen_Abbrev; + begin + if Decl = O_Dnode_Null then + if Abbrev_Struct = 0 then + Generate_Abbrev (Abbrev_Struct); + + Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Struct); + else + if Abbrev_Struct_Name = 0 then + Generate_Abbrev (Abbrev_Struct_Name); + + Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Struct_Name); + end if; + Emit_Members (Atype, Decl); + end Emit_Record_Type; + + procedure Emit_Union_Type (Atype : O_Tnode; Decl : O_Dnode) + is + use Ortho_Code.Types; + procedure Finish_Gen_Abbrev is + begin + Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); + Gen_Abbrev_Tuple (0, 0); + end Finish_Gen_Abbrev; + begin + if Decl = O_Dnode_Null then + if Abbrev_Union = 0 then + Generate_Abbrev (Abbrev_Union); + + Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Union); + else + if Abbrev_Union_Name = 0 then + Generate_Abbrev (Abbrev_Union_Name); + + Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Union_Name); + end if; + Emit_Members (Atype, Decl); + end Emit_Union_Type; + + procedure Emit_Enum_Type (Atype : O_Tnode; Decl : O_Dnode) + is + use Ortho_Code.Types; + use Ortho_Code.Consts; + procedure Finish_Gen_Abbrev is + begin + Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); + Gen_Abbrev_Tuple (0, 0); + end Finish_Gen_Abbrev; + + procedure Emit_Enumerator (L : O_Cnode) is + begin + Gen_Uleb128 (Abbrev_Enumerator); + Emit_Ident (Get_Lit_Ident (L)); + Gen_Uleb128 (Unsigned_32 (Get_Lit_Value (L))); + end Emit_Enumerator; + + Nbr : Uns32; + L : O_Cnode; + Sibling_Pc : Pc_Type; + begin + if Abbrev_Enumerator = 0 then + Generate_Abbrev (Abbrev_Enumerator); + + Gen_Abbrev_Header (DW_TAG_Enumerator, DW_CHILDREN_No); + + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Gen_Abbrev_Tuple (DW_AT_Const_Value, DW_FORM_Udata); + Gen_Abbrev_Tuple (0, 0); + end if; + if Decl = O_Dnode_Null then + if Abbrev_Enum = 0 then + Generate_Abbrev (Abbrev_Enum); + Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Enum); + else + if Abbrev_Enum_Name = 0 then + Generate_Abbrev (Abbrev_Enum_Name); + Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Finish_Gen_Abbrev; + end if; + Gen_Info_Header (Abbrev_Enum_Name); + end if; + + Sibling_Pc := Gen_Info_Sibling; + Emit_Decl_Ident_If_Set (Decl); + Gen_B8 (Byte (Get_Type_Size (Atype))); + case Get_Type_Kind (Atype) is + when OT_Enum => + Nbr := Get_Type_Enum_Nbr_Lits (Atype); + L := Get_Type_Enum_Lits (Atype); + while Nbr > 0 loop + Emit_Enumerator (L); + + L := Get_Lit_Chain (L); + Nbr := Nbr - 1; + end loop; + when OT_Boolean => + Emit_Enumerator (Get_Type_Bool_False (Atype)); + Emit_Enumerator (Get_Type_Bool_True (Atype)); + when others => + raise Program_Error; + end case; + + -- End of children. + Gen_Uleb128 (0); + Patch_Info_Sibling (Sibling_Pc); + end Emit_Enum_Type; + + procedure Emit_Type (Atype : O_Tnode) + is + use Ortho_Code.Types; + use Ada.Text_IO; + Kind : OT_Kind; + Decl : O_Dnode; + begin + -- If already emitted, then return. + if Atype <= TOnodes.Last + and then TOnodes.Table (Atype) /= Null_Pc + then + return; + end if; + + Kind := Get_Type_Kind (Atype); + + -- First step: emit inner types (if any). + case Kind is + when OT_Signed + | OT_Unsigned + | OT_Float + | OT_Boolean + | OT_Enum => + null; + when OT_Access => + null; + when OT_Ucarray => + Emit_Type (Get_Type_Ucarray_Index (Atype)); + Emit_Type (Get_Type_Ucarray_Element (Atype)); + when OT_Subarray => + Emit_Type (Get_Type_Subarray_Base (Atype)); + when OT_Record + | OT_Union => + declare + Nbr : Uns32; + F : O_Fnode; + begin + Nbr := Get_Type_Record_Nbr_Fields (Atype); + F := Get_Type_Record_Fields (Atype); + while Nbr > 0 loop + Emit_Type (Get_Field_Type (F)); + F := Get_Field_Chain (F); + Nbr := Nbr - 1; + end loop; + end; + when OT_Complete => + null; + end case; + + Set_Current_Section (Info_Sect); + Add_Type_Ref (Atype, Get_Current_Pc); + + Decl := Decls.Get_Type_Decl (Atype); + + -- Second step: emit info. + case Kind is + when OT_Signed + | OT_Unsigned + | OT_Float => + Emit_Base_Type (Atype, Decl); + -- base types. + when OT_Access => + Emit_Access_Type (Atype, Decl); + when OT_Ucarray => + Emit_Ucarray_Type (Atype, Decl); + when OT_Subarray => + Emit_Subarray_Type (Atype, Decl); + when OT_Record => + Emit_Record_Type (Atype, Decl); + when OT_Union => + Emit_Union_Type (Atype, Decl); + when OT_Enum + | OT_Boolean => + Emit_Enum_Type (Atype, Decl); + when OT_Complete => + null; + end case; + end Emit_Type; + + procedure Emit_Decl_Type (Decl : O_Dnode) + is + use Ortho_Code.Decls; + begin + Emit_Type_Ref (Get_Decl_Type (Decl)); + end Emit_Decl_Type; + + Abbrev_Variable : Unsigned_32 := 0; + Abbrev_Const : Unsigned_32 := 0; + + procedure Emit_Local_Location (Decl : O_Dnode) + is + use Ortho_Code.Decls; + Pc : Pc_Type; + begin + Pc := Get_Current_Pc; + Gen_B8 (2); + Gen_B8 (DW_OP_Fbreg); + Gen_Sleb128 (Get_Decl_Info (Decl)); + Patch_B8 (Pc, Unsigned_8 (Get_Current_Pc - (Pc + 1))); + end Emit_Local_Location; + + procedure Emit_Global_Location (Decl : O_Dnode) + is + use Ortho_Code.Binary; + begin + Gen_B8 (5); + Gen_B8 (DW_OP_Addr); + Gen_Ua_32 (Get_Decl_Symbol (Decl), 0); + end Emit_Global_Location; + + procedure Emit_Variable (Decl : O_Dnode) + is + use Ortho_Code.Decls; + Dtype : O_Tnode; + begin + if Get_Decl_Ident (Decl) = O_Ident_Nul then + return; + end if; + + if Abbrev_Variable = 0 then + Generate_Abbrev (Abbrev_Variable); + Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No); + + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); + Gen_Abbrev_Tuple (0, 0); + end if; + + Dtype := Get_Decl_Type (Decl); + Emit_Type (Dtype); + + Gen_Info_Header (Abbrev_Variable); + Emit_Decl_Ident (Decl); + Emit_Type_Ref (Dtype); + case Get_Decl_Kind (Decl) is + when OD_Local => + Emit_Local_Location (Decl); + when OD_Var => + Emit_Global_Location (Decl); + when others => + raise Program_Error; + end case; + end Emit_Variable; + + procedure Emit_Const (Decl : O_Dnode) + is + use Ortho_Code.Decls; + Dtype : O_Tnode; + begin + if Abbrev_Const = 0 then + Generate_Abbrev (Abbrev_Const); + -- FIXME: should be a TAG_Constant, however, GDB does not support it. + -- work-around: could use a const_type. + Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No); + + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); + Gen_Abbrev_Tuple (0, 0); + end if; + + Dtype := Get_Decl_Type (Decl); + Emit_Type (Dtype); + Gen_Info_Header (Abbrev_Const); + Emit_Decl_Ident (Decl); + Emit_Type_Ref (Dtype); + Emit_Global_Location (Decl); + end Emit_Const; + + procedure Emit_Type_Decl (Decl : O_Dnode) + is + use Ortho_Code.Decls; + begin + Emit_Type (Get_Decl_Type (Decl)); + end Emit_Type_Decl; + + Subprg_Sym : Symbol; + + Abbrev_Block : Unsigned_32 := 0; + + procedure Emit_Block_Decl (Decl : O_Dnode) + is + use Ortho_Code.Decls; + Last : O_Dnode; + Sdecl : O_Dnode; + Sibling_Pc : Pc_Type; + begin + if Abbrev_Block = 0 then + Generate_Abbrev (Abbrev_Block); + + Gen_Abbrev_Header (DW_TAG_Lexical_Block, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (0, 0); + end if; + + Gen_Info_Header (Abbrev_Block); + Sibling_Pc := Gen_Info_Sibling; + + Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl))); + Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl))); + + -- Emit decls for children. + Last := Get_Block_Last (Decl); + Sdecl := Decl + 1; + while Sdecl <= Last loop + Emit_Decl (Sdecl); + Sdecl := Get_Decl_Chain (Sdecl); + end loop; + + -- End of children. + Set_Current_Section (Info_Sect); + Gen_Uleb128 (0); + + Patch_Info_Sibling (Sibling_Pc); + end Emit_Block_Decl; + + Abbrev_Function : Unsigned_32 := 0; + Abbrev_Procedure : Unsigned_32 := 0; + Abbrev_Interface : Unsigned_32 := 0; + + procedure Emit_Subprg_Body (Bod : O_Dnode) + is + use Ortho_Code.Decls; + Kind : OD_Kind; + Decl : O_Dnode; + Idecl : O_Dnode; + Prev_Subprg_Sym : Symbol; + Sibling_Pc : Pc_Type; + begin + Decl := Get_Body_Decl (Bod); + Kind := Get_Decl_Kind (Decl); + + -- Emit interfaces type. + Idecl := Get_Subprg_Interfaces (Decl); + while Idecl /= O_Dnode_Null loop + Emit_Type (Get_Decl_Type (Idecl)); + Idecl := Get_Interface_Chain (Idecl); + end loop; + + if Kind = OD_Function then + Emit_Type (Get_Decl_Type (Decl)); + if Abbrev_Function = 0 then + Generate_Abbrev (Abbrev_Function); + + Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); + --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); + Gen_Abbrev_Tuple (0, 0); + end if; + Gen_Info_Header (Abbrev_Function); + else + if Abbrev_Procedure = 0 then + Generate_Abbrev (Abbrev_Procedure); + + Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes); + Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); + + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); + Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); + --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); + Gen_Abbrev_Tuple (0, 0); + end if; + Gen_Info_Header (Abbrev_Procedure); + end if; + + Sibling_Pc := Gen_Info_Sibling; + + if Kind = OD_Function then + Emit_Decl_Type (Decl); + end if; + + Emit_Decl_Ident (Decl); + Prev_Subprg_Sym := Subprg_Sym; + Subprg_Sym := Binary.Get_Decl_Symbol (Decl); + Gen_Ua_32 (Subprg_Sym, 0); + Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Body_Info (Bod))); + + -- Frame base. + Gen_B8 (1); + Gen_B8 (DW_OP_Reg5); + + -- Interfaces. + Idecl := Get_Subprg_Interfaces (Decl); + if Idecl /= O_Dnode_Null then + if Abbrev_Interface = 0 then + Generate_Abbrev (Abbrev_Interface); + + Gen_Abbrev_Header (DW_TAG_Formal_Parameter, DW_CHILDREN_No); + Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); + Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); + Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); + Gen_Abbrev_Tuple (0, 0); + end if; + + loop + Gen_Info_Header (Abbrev_Interface); + Emit_Decl_Type (Idecl); + Emit_Decl_Ident (Idecl); + + Emit_Local_Location (Idecl); + + Idecl := Get_Interface_Chain (Idecl); + exit when Idecl = O_Dnode_Null; + end loop; + end if; + + -- Internal declarations. + Emit_Block_Decl (Bod + 1); + + -- End of children. + Gen_Uleb128 (0); + + Patch_Info_Sibling (Sibling_Pc); + + Subprg_Sym := Prev_Subprg_Sym; + end Emit_Subprg_Body; + + procedure Emit_Decl (Decl : O_Dnode) + is + use Ada.Text_IO; + use Ortho_Code.Decls; + begin + case Get_Decl_Kind (Decl) is + when OD_Type => + Emit_Type_Decl (Decl); + when OD_Local + | OD_Var => + Emit_Variable (Decl); + when OD_Const => + Emit_Const (Decl); + when OD_Function + | OD_Procedure + | OD_Interface => + null; + when OD_Body => + Emit_Subprg_Body (Decl); + when OD_Block => + Emit_Block_Decl (Decl); + when others => + Put_Line ("dwarf.emit_decl: emit " + & OD_Kind'Image (Get_Decl_Kind (Decl))); + end case; + end Emit_Decl; + + procedure Emit_Subprg (Bod : O_Dnode) is + begin + Emit_Decls_Until (Bod); + Emit_Decl (Bod); + Last_Decl := Decls.Get_Decl_Chain (Bod); + end Emit_Subprg; + + procedure Mark (M : out Mark_Type) is + begin + M.Last_Decl := Last_Decl; + M.Last_Tnode := TOnodes.Last; + end Mark; + + procedure Release (M : Mark_Type) is + begin + Last_Decl := M.Last_Decl; + TOnodes.Set_Last (M.Last_Tnode); + end Release; + +end Ortho_Code.Dwarf; + |