-- 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 Tables; with Interfaces; use Interfaces; with Dwarf; use Dwarf; with Ada.Text_IO; with Ortho_Code.Flags; use Ortho_Code.Flags; with Ortho_Code.Decls; with Ortho_Code.Types; with Ortho_Code.Consts; 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; Abbrev_Last : Unsigned_32; procedure Gen_String_Nul (Str : String) is begin Prealloc (Str'Length + 1); for I in Str'Range loop Gen_8 (Character'Pos (Str (I))); end loop; Gen_8 (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_8 (B); exit; else Gen_8 (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_8 (B or 16#80#); else Gen_8 (B); exit; end if; end loop; end Gen_Uleb128; 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_8 (Byte (DW_LNS_Set_File)); Gen_Uleb128 (Unsigned_32 (Cur_File)); Last_File := Cur_File; elsif Cur_File = 0 then -- No file yet. return; end if; if D_Ln < Line_Base or D_Ln >= (Line_Base + Line_Range) then -- Emit an advance line. Gen_8 (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_8 (Byte (DW_LNS_Advance_Pc)); Gen_Uleb128 (Unsigned_32 (D_Pc)); D_Pc := 0; end if; Gen_8 (Line_Opcode_Base + Byte (D_Pc) * Line_Range + Byte (D_Ln - Line_Base)); 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_8 (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_8 (0); -- extended opcode Gen_8 (1 + Pc_Type_Sizeof); -- length Gen_8 (Byte (DW_LNE_Set_Address)); Gen_Ua_Addr (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); -- Abbrev offset Gen_8 (Pc_Type_Sizeof); -- Ptr size. -- Compile_unit. Gen_Uleb128 (1); Gen_Ua_32 (Line_Sym); Gen_Ua_Addr (Orig_Sym, 0); Gen_Ua_Addr (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); Prealloc (32); -- 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_8 (Min_Insn_Len); -- default_is_stmt Gen_8 (1); -- line base Gen_8 (Line_Base); 
/*---------------------------------------------------------------------------/
/  FatFs - FAT file system module configuration file  R0.09a (C)ChaN, 2012
/----------------------------------------------------------------------------/
/
/ CAUTION! Do not forget to make clean the project after any changes to
/ the configuration options.
/
/----------------------------------------------------------------------------*/
#ifndef _FFCONF
#define _FFCONF 4004	/* Revision ID */


/*---------------------------------------------------------------------------/
/ Function and Buffer Configurations
/----------------------------------------------------------------------------*/

#define	_FS_TINY	1		/* 0:Normal or 1:Tiny */
/* When _FS_TINY is set to 1, FatFs uses the sector buffer in the file system
/  object instead of the sector buffer in the individual file object for file
/  data transfer. This reduces memory consumption 512 bytes each file object. */


#define _FS_READONLY	0	/* 0:Read/Write or 1:Read only */
/* Setting _FS_READONLY to 1 defines read only configuration. This removes
/  writing functions, f_write, f_sync, f_unlink, f_mkdir, f_chmod, f_rename,
/  f_truncate and useless f_getfree. */


#define _FS_MINIMIZE	2	/* 0 to 3 */
/* The _FS_MINIMIZE option defines minimization level to remove some functions.
/
/   0: Full function.
/   1: f_stat, f_getfree, f_unlink, f_mkdir, f_chmod, f_truncate and f_rename
/      are removed.
/   2: f_opendir and f_readdir are removed in addition to 1.
/   3: f_lseek is removed in addition to 2. */


#define	_USE_STRFUNC	0	/* 0:Disable or 1-2:Enable */
/* To enable string functions, set _USE_STRFUNC to 1 or 2. */


#define	_USE_MKFS	0		/* 0:Disable or 1:Enable */
/* To enable f_mkfs function, set _USE_MKFS to 1 and set _FS_READONLY to 0 */


#define	_USE_FORWARD	0	/* 0:Disable or 1:Enable */
/* To enable f_forward function, set _USE_FORWARD to 1 and set _FS_TINY to 1. */


#define	_USE_FASTSEEK	0	/* 0:Disable or 1:Enable */
/* To enable fast seek feature, set _USE_FASTSEEK to 1. */



/*---------------------------------------------------------------------------/
/ Locale and Namespace Configurations
/----------------------------------------------------------------------------*/

#define _CODE_PAGE	932
/* The _CODE_PAGE specifies the OEM code page to be used on the target system.
/  Incorrect setting of the code page can cause a file open failure.
/
/   932  - Japanese Shift-JIS (DBCS, OEM, Windows)
/   936  - Simplified Chinese GBK (DBCS, OEM, Windows)
/   949  - Korean (DBCS, OEM, Windows)
/   950  - Traditional Chinese Big5 (DBCS, OEM, Windows)
/   1250 - Central Europe (Windows)
/   1251 - Cyrillic (Windows)
/   1252 - Latin 1 (Windows)
/   1253 - Greek (Windows)
/   1254 - Turkish (Windows)
/   1255 - Hebrew (Windows)
/   1256 - Arabic (Windows)
/   1257 - Baltic (Windows)
/   1258 - Vietnam (OEM, Windows)
/   437  - U.S. (OEM)
/   720  - Arabic (OEM)
/   737  - Greek (OEM)
/   775  - Baltic (OEM)
/   850  - Multilingual Latin 1 (OEM)
/   858  - Multilingual Latin 1 + Euro (OEM)
/   852  - Latin 2 (OEM)
/   855  - Cyrillic (OEM)
/   866  - Russian (OEM)
/   857  - Turkish (OEM)
/   862  - Hebrew (OEM)
/   874  - Thai (OEM, Windows)
/	1    - ASCII only (Valid for non LFN cfg.)
*/


#define	_USE_LFN	0		/* 0 to 3 */
#define	_MAX_LFN	255		/* Maximum LFN length to handle (12 to 255) */
/* The _USE_LFN option switches the LFN support.
/
/   0: Disable LFN feature. _MAX_LFN and _LFN_UNICODE have no effect.
/   1: Enable LFN with static working buffer on the BSS. Always NOT reentrant.
/   2: Enable LFN with dynamic working buffer on the STACK.
/   3: Enable LFN with dynamic working buffer on the HEAP.
/
/  The LFN working buffer occupies (_MAX_LFN + 1) * 2 bytes. To enable LFN,
/  Unicode handling functions ff_convert() and ff_wtoupper() must be added
/  to the project. When enable to use heap, memory control functions
/  ff_memalloc() and ff_memfree() must be added to the project. */


#define	_LFN_UNICODE	0	/* 0:ANSI/OEM or 1:Unicode */
/* To switch the character code set on FatFs API to Unicode,
/  enable LFN feature and set _LFN_UNICODE to 1. */


#define _FS_RPATH		0	/* 0 to 2 */
/* The _FS_RPATH option configures relative path feature.
/
/   0: Disable relative path feature and remove related functions.
/   1: Enable relative path. f_chdrive() and f_chdir() are available.
/   2: f_getcwd() is available in addition to 1.
/
/  Note that output of the f_readdir fnction is affected by this option. */



/*---------------------------------------------------------------------------/
/ Physical Drive Configurations
/----------------------------------------------------------------------------*/

#define _VOLUMES	1
/* Number of volumes (logical drives) to be used. */


#define	_MAX_SS		512		/* 512, 1024, 2048 or 4096 */
/* Maximum sector size to be handled.
/  Always set 512 for memory card and hard disk but a larger value may be
/  required for on-board flash memory, floppy disk and optical disk.
/  When _MAX_SS is larger than 512, it configures FatFs to variable sector size
/  and GET_SECTOR_SIZE command must be implememted to the disk_ioctl function. */


#define	_MULTI_PARTITION	0	/* 0:Single partition, 1/2:Enable multiple partition */
/* When set to 0, each volume is bound to the same physical drive number and
/ it can mount only first primaly partition. When it is set to 1, each volume
/ is tied to the partitions listed in VolToPart[]. */


#define	_USE_ERASE	0	/* 0:Disable or 1:Enable */
/* To enable sector erase feature, set _USE_ERASE to 1. CTRL_ERASE_SECTOR command
/  should be added to the disk_ioctl functio. */



/*---------------------------------------------------------------------------/
/ System Configurations
/----------------------------------------------------------------------------*/

#define _WORD_ACCESS	1	/* 0 or 1 */
/* Set 0 first and it is always compatible with all platforms. The _WORD_ACCESS
/  option defines which access method is used to the word data on the FAT volume.
/
/   0: Byte-by-byte access.
/   1: Word access. Do not choose this unless following condition is met.
/
/  When the byte order on the memory is big-endian or address miss-aligned word
/  access results incorrect behavior, the _WORD_ACCESS must be set to 0.
/  If it is not the case, the value can also be set to 1 to improve the
/  performance and code size.
*/


/* A header file that defines sync object types on the O/S, such as
/  windows.h, ucos_ii.h and semphr.h, must be included prior to ff.h. */

#define _FS_REENTRANT	0		/* 0:Disable or 1:Enable */
#define _FS_TIMEOUT		1000	/* Timeout period in unit of time ticks */
#define	_SYNC_t			HANDLE	/* O/S dependent type of sync object. e.g. HANDLE, OS_EVENT*, ID and etc.. */

/* The _FS_REENTRANT option switches the reentrancy (thread safe) of the FatFs module.
/
/   0: Disable reentrancy. _SYNC_t and _FS_TIMEOUT have no effect.
/   1: Enable reentrancy. Also user provided synchronization handlers,
/      ff_req_grant, ff_rel_grant, ff_del_syncobj and ff_cre_syncobj
/      function must be added to the project. */


#define	_FS_LOCK	0	/* 0:Disable or >=1:Enable */
/* To enable file lock control feature, set _FS_LOCK to 1 or greater.
   The value defines how many files can be opened simultaneously. */


#endif /* _FFCONFIG */
generated by cgit v1.2.3 (git 2.25.1) at 2025-06-02 16:15:26 +0000
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_8 (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 Flag_Debug < Debug_Dwarf then return; end if; -- 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_8 (2); Gen_8 (DW_OP_Fbreg); Gen_Sleb128 (Get_Decl_Info (Decl)); Patch_8 (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_8 (1 + Pc_Type_Sizeof); Gen_8 (DW_OP_Addr); Gen_Ua_Addr (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 Flag_Debug >= Debug_Dwarf then 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_Addr (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl))); Gen_Ua_Addr (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl))); end if; -- 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; if Flag_Debug >= Debug_Dwarf then -- End of children. Set_Current_Section (Info_Sect); Gen_Uleb128 (0); Patch_Info_Sibling (Sibling_Pc); end if; 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; Decl : constant O_Dnode := Get_Body_Decl (Bod); Kind : constant OD_Kind := Get_Decl_Kind (Decl); Idecl : O_Dnode; Prev_Subprg_Sym : Symbol; Sibling_Pc : Pc_Type; begin -- 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_Name, DW_FORM_String); Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); if Flag_Debug >= Debug_Dwarf then Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); end if; --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_Name, DW_FORM_String); Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); if Flag_Debug >= Debug_Dwarf then Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); end if; --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); Gen_Abbrev_Tuple (0, 0); end if; Gen_Info_Header (Abbrev_Procedure); end if; -- Name. Emit_Decl_Ident (Decl); -- Low, High. Prev_Subprg_Sym := Subprg_Sym; Subprg_Sym := Binary.Get_Decl_Symbol (Decl); Gen_Ua_Addr (Subprg_Sym, 0); Gen_Ua_Addr (Subprg_Sym, Integer_32 (Get_Body_Info (Bod))); if Flag_Debug >= Debug_Dwarf then -- Type. if Kind = OD_Function then Emit_Decl_Type (Decl); end if; -- Sibling. Sibling_Pc := Gen_Info_Sibling; -- Frame base. Gen_8 (1); case Arch is when Arch_X86 => Gen_8 (DW_OP_Reg5); -- ebp when Arch_X86_64 => Gen_8 (DW_OP_Reg6); -- rbp when others => raise Program_Error; end case; end if; -- Interfaces. Idecl := Get_Subprg_Interfaces (Decl); if Idecl /= O_Dnode_Null and then Flag_Debug >= Debug_Dwarf 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); if Flag_Debug >= Debug_Dwarf then Patch_Info_Sibling (Sibling_Pc); end if; 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 if Flag_Debug = Debug_Dwarf then 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; elsif Flag_Debug = Debug_Line then if Get_Decl_Kind (Decl) = OD_Body then Emit_Subprg_Body (Decl); end if; end if; 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;