1-- Mcode back-end for ortho - Dwarf generator. 2-- Copyright (C) 2006 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16with GNAT.Directory_Operations; 17with Tables; 18with Interfaces; use Interfaces; 19with Dwarf; use Dwarf; 20with Ada.Text_IO; 21with Ortho_Code.Flags; use Ortho_Code.Flags; 22with Ortho_Code.Decls; 23with Ortho_Code.Types; 24with Ortho_Code.Consts; 25with Ortho_Ident; 26with Ortho_Code.Binary; 27 28package body Ortho_Code.Dwarf is 29 -- Dwarf debugging format. 30 -- Debugging. 31 Line1_Sect : Section_Acc := null; 32 Line_Last : Int32 := 0; 33 Line_Pc : Pc_Type := 0; 34 35 -- Constant. 36 Min_Insn_Len : constant := 1; 37 Line_Base : constant := 1; 38 Line_Range : constant := 4; 39 Line_Opcode_Base : constant := 13; 40 Line_Max_Addr : constant := (255 - Line_Opcode_Base) / Line_Range; 41 -- + Line_Base; 42 43 Cur_File : Natural := 0; 44 Last_File : Natural := 0; 45 46 Orig_Sym : Symbol; 47 End_Sym : Symbol; 48 Abbrev_Sym : Symbol; 49 Info_Sym : Symbol; 50 Line_Sym : Symbol; 51 52 Abbrev_Last : Unsigned_32; 53 54 procedure Gen_String_Nul (Str : String) 55 is 56 begin 57 Prealloc (Str'Length + 1); 58 for I in Str'Range loop 59 Gen_8 (Character'Pos (Str (I))); 60 end loop; 61 Gen_8 (0); 62 end Gen_String_Nul; 63 64 procedure Gen_Sleb128 (V : Int32) 65 is 66 V1 : Uns32 := To_Uns32 (V); 67 V2 : Uns32; 68 B : Byte; 69 function Shift_Right_Arithmetic (Value : Uns32; Amount : Natural) 70 return Uns32; 71 pragma Import (Intrinsic, Shift_Right_Arithmetic); 72 begin 73 loop 74 B := Byte (V1 and 16#7F#); 75 V2 := Shift_Right_Arithmetic (V1, 7); 76 if (V2 = 0 and (B and 16#40#) = 0) 77 or (V2 = -1 and (B and 16#40#) /= 0) 78 then 79 Gen_8 (B); 80 exit; 81 else 82 Gen_8 (B or 16#80#); 83 V1 := V2; 84 end if; 85 end loop; 86 end Gen_Sleb128; 87 88 procedure Gen_Uleb128 (V : Unsigned_32) 89 is 90 V1 : Unsigned_32 := V; 91 B : Byte; 92 begin 93 loop 94 B := Byte (V1 and 16#7f#); 95 V1 := Shift_Right (V1, 7); 96 if V1 /= 0 then 97 Gen_8 (B or 16#80#); 98 else 99 Gen_8 (B); 100 exit; 101 end if; 102 end loop; 103 end Gen_Uleb128; 104 105 procedure Set_Line_Stmt (Line : Int32) 106 is 107 Pc : Pc_Type; 108 D_Pc : Pc_Type; 109 D_Ln : Int32; 110 begin 111 if Line = Line_Last then 112 return; 113 end if; 114 Pc := Get_Current_Pc; 115 116 D_Pc := (Pc - Line_Pc) / Min_Insn_Len; 117 D_Ln := Line - Line_Last; 118 119 -- Always emit line information, since missing info can distrub the 120 -- user. 121 -- As an optimization, we could try to emit the highest line for the 122 -- same PC, since GDB seems to handle this way. 123 if False and D_Pc = 0 then 124 return; 125 end if; 126 127 Set_Current_Section (Line1_Sect); 128 Prealloc (32); 129 130 if Cur_File /= Last_File then 131 Gen_8 (Byte (DW_LNS_Set_File)); 132 Gen_Uleb128 (Unsigned_32 (Cur_File)); 133 Last_File := Cur_File; 134 elsif Cur_File = 0 then 135 -- No file yet. 136 return; 137 end if; 138 139 if D_Ln < Line_Base or D_Ln >= (Line_Base + Line_Range) then 140 -- Emit an advance line. 141 Gen_8 (Byte (DW_LNS_Advance_Line)); 142 Gen_Sleb128 (Int32 (D_Ln - Line_Base)); 143 D_Ln := Line_Base; 144 end if; 145 if D_Pc >= Line_Max_Addr then 146 -- Emit an advance addr. 147 Gen_8 (Byte (DW_LNS_Advance_Pc)); 148 Gen_Uleb128 (Unsigned_32 (D_Pc)); 149 D_Pc := 0; 150 end if; 151 Gen_8 (Line_Opcode_Base 152 + Byte (D_Pc) * Line_Range 153 + Byte (D_Ln - Line_Base)); 154 155 Line_Pc := Pc; 156 Line_Last := Line; 157 end Set_Line_Stmt; 158 159 160 type String_Acc is access constant String; 161 162 type Dir_Chain; 163 type Dir_Chain_Acc is access Dir_Chain; 164 type Dir_Chain is record 165 Name : String_Acc; 166 Next : Dir_Chain_Acc; 167 end record; 168 169 type File_Chain; 170 type File_Chain_Acc is access File_Chain; 171 type File_Chain is record 172 Name : String_Acc; 173 Dir : Natural; 174 Next : File_Chain_Acc; 175 end record; 176 177 Dirs : Dir_Chain_Acc := null; 178 Files : File_Chain_Acc := null; 179 180 procedure Set_Filename (Dir : String; File : String) 181 is 182 D : Natural; 183 F : Natural; 184 D_C : Dir_Chain_Acc; 185 F_C : File_Chain_Acc; 186 begin 187 -- Find directory. 188 if Dir = "" then 189 -- Current directory. 190 D := 0; 191 elsif Dirs = null then 192 -- First directory. 193 Dirs := new Dir_Chain'(Name => new String'(Dir), 194 Next => null); 195 D := 1; 196 else 197 -- Find a directory. 198 D_C := Dirs; 199 D := 1; 200 loop 201 exit when D_C.Name.all = Dir; 202 D := D + 1; 203 if D_C.Next = null then 204 D_C.Next := new Dir_Chain'(Name => new String'(Dir), 205 Next => null); 206 exit; 207 else 208 D_C := D_C.Next; 209 end if; 210 end loop; 211 end if; 212 213 -- Find file. 214 F := 1; 215 if Files = null then 216 -- first file. 217 Files := new File_Chain'(Name => new String'(File), 218 Dir => D, 219 Next => null); 220 else 221 F_C := Files; 222 loop 223 exit when F_C.Name.all = File and F_C.Dir = D; 224 F := F + 1; 225 if F_C.Next = null then 226 F_C.Next := new File_Chain'(Name => new String'(File), 227 Dir => D, 228 Next => null); 229 exit; 230 else 231 F_C := F_C.Next; 232 end if; 233 end loop; 234 end if; 235 Cur_File := F; 236 end Set_Filename; 237 238 procedure Gen_Abbrev_Header (Tag : Unsigned_32; Child : Byte) is 239 begin 240 Gen_Uleb128 (Tag); 241 Gen_8 (Child); 242 end Gen_Abbrev_Header; 243 244 procedure Gen_Abbrev_Tuple (Attr : Unsigned_32; Form : Unsigned_32) is 245 begin 246 Gen_Uleb128 (Attr); 247 Gen_Uleb128 (Form); 248 end Gen_Abbrev_Tuple; 249 250 procedure Init is 251 begin 252 -- Generate type names. 253 Flags.Flag_Type_Name := True; 254 255 Orig_Sym := Create_Local_Symbol; 256 Set_Symbol_Pc (Orig_Sym, False); 257 End_Sym := Create_Local_Symbol; 258 259 Create_Section (Line1_Sect, ".debug_line-1", Section_Debug); 260 Set_Current_Section (Line1_Sect); 261 262 -- Write Address. 263 Gen_8 (0); -- extended opcode 264 Gen_8 (1 + Pc_Type_Sizeof); -- length 265 Gen_8 (Byte (DW_LNE_Set_Address)); 266 Gen_Ua_Addr (Orig_Sym, 0); 267 268 Line_Last := 1; 269 270 Create_Section (Line_Sect, ".debug_line", Section_Debug); 271 Set_Section_Info (Line_Sect, null, 0, 0); 272 Set_Current_Section (Line_Sect); 273 Line_Sym := Create_Local_Symbol; 274 Set_Symbol_Pc (Line_Sym, False); 275 276 -- Abbrevs. 277 Create_Section (Abbrev_Sect, ".debug_abbrev", Section_Debug); 278 Set_Section_Info (Abbrev_Sect, null, 0, 0); 279 Set_Current_Section (Abbrev_Sect); 280 281 Abbrev_Sym := Create_Local_Symbol; 282 Set_Symbol_Pc (Abbrev_Sym, False); 283 284 Gen_Uleb128 (1); 285 Gen_Abbrev_Header (DW_TAG_Compile_Unit, DW_CHILDREN_Yes); 286 287 Gen_Abbrev_Tuple (DW_AT_Stmt_List, DW_FORM_Data4); 288 Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); 289 Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); 290 Gen_Abbrev_Tuple (DW_AT_Producer, DW_FORM_String); 291 Gen_Abbrev_Tuple (DW_AT_Comp_Dir, DW_FORM_String); 292 Gen_Abbrev_Tuple (0, 0); 293 294 Abbrev_Last := 1; 295 296 -- Info. 297 Create_Section (Info_Sect, ".debug_info", Section_Debug); 298 Set_Section_Info (Info_Sect, null, 0, 0); 299 Set_Current_Section (Info_Sect); 300 Info_Sym := Create_Local_Symbol; 301 Set_Symbol_Pc (Info_Sym, False); 302 303 Gen_32 (7); -- Length: to be patched. 304 Gen_16 (2); -- version 305 Gen_Ua_32 (Abbrev_Sym); -- Abbrev offset 306 Gen_8 (Pc_Type_Sizeof); -- Ptr size. 307 308 -- Compile_unit. 309 Gen_Uleb128 (1); 310 Gen_Ua_32 (Line_Sym); 311 Gen_Ua_Addr (Orig_Sym, 0); 312 Gen_Ua_Addr (End_Sym, 0); 313 Gen_String_Nul ("T.Gingold ortho_mcode (2004)"); 314 Gen_String_Nul (GNAT.Directory_Operations.Get_Current_Dir); 315 end Init; 316 317 procedure Emit_Decl (Decl : O_Dnode); 318 319 -- Next node to be emitted. 320 Last_Decl : O_Dnode := O_Dnode_First; 321 322 procedure Emit_Decls_Until (Last : O_Dnode) 323 is 324 use Ortho_Code.Decls; 325 begin 326 while Last_Decl < Last loop 327 Emit_Decl (Last_Decl); 328 Last_Decl := Get_Decl_Chain (Last_Decl); 329 end loop; 330 end Emit_Decls_Until; 331 332 procedure Finish 333 is 334 Length : Pc_Type; 335 Last : O_Dnode; 336 begin 337 Set_Symbol_Pc (End_Sym, False); 338 Length := Get_Current_Pc; 339 340 Last := Decls.Get_Decl_Last; 341 Emit_Decls_Until (Last); 342 if Last_Decl <= Last then 343 Emit_Decl (Last); 344 end if; 345 346 -- Finish abbrevs. 347 Set_Current_Section (Abbrev_Sect); 348 Gen_Uleb128 (0); 349 350 -- Emit header. 351 Set_Current_Section (Line_Sect); 352 Prealloc (32); 353 354 -- Unit_Length (to be patched). 355 Gen_32 (0); 356 -- version 357 Gen_16 (2); 358 -- header_length (to be patched). 359 Gen_32 (5 + 12 + 1); 360 -- minimum_instruction_length. 361 Gen_8 (Min_Insn_Len); 362 -- default_is_stmt 363 Gen_8 (1); 364 -- line base 365 Gen_8 (Line_Base); 366 -- line range 367 Gen_8 (Line_Range); 368 -- opcode base 369 Gen_8 (Line_Opcode_Base); 370 -- standard_opcode_length. 371 Gen_8 (0); -- copy 372 Gen_8 (1); -- advance pc 373 Gen_8 (1); -- advance line 374 Gen_8 (1); -- set file 375 Gen_8 (1); -- set column 376 Gen_8 (0); -- negate stmt 377 Gen_8 (0); -- set basic block 378 Gen_8 (0); -- const add pc 379 Gen_8 (1); -- fixed advance pc 380 Gen_8 (0); -- set prologue end 381 Gen_8 (0); -- set epilogue begin 382 Gen_8 (1); -- set isa 383 --if Line_Opcode_Base /= 13 then 384 -- raise Program_Error; 385 --end if; 386 387 -- include directories 388 declare 389 D : Dir_Chain_Acc; 390 begin 391 D := Dirs; 392 while D /= null loop 393 Gen_String_Nul (D.Name.all); 394 D := D.Next; 395 end loop; 396 Prealloc (1); 397 Gen_8 (0); -- last entry. 398 end; 399 400 -- file_names. 401 declare 402 F : File_Chain_Acc; 403 begin 404 F := Files; 405 while F /= null loop 406 Gen_String_Nul (F.Name.all); 407 Prealloc (8); 408 Gen_Uleb128 (Unsigned_32 (F.Dir)); 409 Gen_8 (0); -- time 410 Gen_8 (0); -- length 411 F := F.Next; 412 end loop; 413 Gen_8 (0); -- last entry. 414 end; 415 416 -- Set prolog length 417 Patch_32 (6, Unsigned_32 (Get_Current_Pc - 6)); 418 419 Merge_Section (Line_Sect, Line1_Sect); 420 Prealloc (4); 421 422 -- Emit end of sequence. 423 Gen_8 (0); -- extended opcode 424 Gen_8 (1); -- length: 1 425 Gen_8 (Byte (DW_LNE_End_Sequence)); 426 427 -- Set total length. 428 Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4)); 429 430 -- Info. 431 Set_Current_Section (Info_Sect); 432 Prealloc (8); 433 -- Finish child. 434 Gen_Uleb128 (0); 435 -- Set total length. 436 Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4)); 437 438 -- Aranges 439 Create_Section (Aranges_Sect, ".debug_aranges", Section_Debug); 440 Set_Section_Info (Aranges_Sect, null, 0, 0); 441 Set_Current_Section (Aranges_Sect); 442 443 Prealloc (32); 444 Gen_32 (24 + Pc_Type_Sizeof); -- Length. 445 Gen_16 (2); -- version 446 Gen_Ua_32 (Info_Sym); -- info offset 447 Gen_8 (Pc_Type_Sizeof); -- Ptr size. 448 Gen_8 (0); -- seg desc size. 449 Gen_32 (0); -- pad 450 Gen_Ua_Addr (Orig_Sym, 0); -- text offset 451 Gen_32 (Unsigned_32 (Length)); 452 Gen_32 (0); -- End 453 Gen_32 (0); 454 end Finish; 455 456 procedure Generate_Abbrev (Abbrev : out Unsigned_32) is 457 begin 458 Abbrev_Last := Abbrev_Last + 1; 459 Abbrev := Abbrev_Last; 460 461 Set_Current_Section (Abbrev_Sect); 462 -- FIXME: should be enough ? 463 Prealloc (128); 464 Gen_Uleb128 (Abbrev); 465 end Generate_Abbrev; 466 467 procedure Gen_Info_Header (Abbrev : Unsigned_32) is 468 begin 469 Set_Current_Section (Info_Sect); 470 Gen_Uleb128 (Abbrev); 471 end Gen_Info_Header; 472 473 function Gen_Info_Sibling return Pc_Type 474 is 475 Pc : Pc_Type; 476 begin 477 Pc := Get_Current_Pc; 478 Gen_32 (0); 479 return Pc; 480 end Gen_Info_Sibling; 481 482 procedure Patch_Info_Sibling (Pc : Pc_Type) is 483 begin 484 Patch_32 (Pc, Unsigned_32 (Get_Current_Pc)); 485 end Patch_Info_Sibling; 486 487 Abbrev_Base_Type : Unsigned_32 := 0; 488 Abbrev_Base_Type_Name : Unsigned_32 := 0; 489 Abbrev_Pointer : Unsigned_32 := 0; 490 Abbrev_Pointer_Name : Unsigned_32 := 0; 491 Abbrev_Uncomplete_Pointer : Unsigned_32 := 0; 492 Abbrev_Uncomplete_Pointer_Name : Unsigned_32 := 0; 493 Abbrev_Ucarray : Unsigned_32 := 0; 494 Abbrev_Ucarray_Name : Unsigned_32 := 0; 495 Abbrev_Uc_Subrange : Unsigned_32 := 0; 496 Abbrev_Subarray : Unsigned_32 := 0; 497 Abbrev_Subarray_Name : Unsigned_32 := 0; 498 Abbrev_Subrange : Unsigned_32 := 0; 499 Abbrev_Struct : Unsigned_32 := 0; 500 Abbrev_Struct_Name : Unsigned_32 := 0; 501 Abbrev_Union : Unsigned_32 := 0; 502 Abbrev_Union_Name : Unsigned_32 := 0; 503 Abbrev_Member : Unsigned_32 := 0; 504 Abbrev_Enum : Unsigned_32 := 0; 505 Abbrev_Enum_Name : Unsigned_32 := 0; 506 Abbrev_Enumerator : Unsigned_32 := 0; 507 508 package TOnodes is new Tables 509 (Table_Component_Type => Pc_Type, 510 Table_Index_Type => O_Tnode, 511 Table_Low_Bound => O_Tnode_First, 512 Table_Initial => 16); 513 514 procedure Emit_Type_Ref (Atype : O_Tnode) 515 is 516 Off : Pc_Type; 517 begin 518 pragma Assert (Flag_Debug >= Debug_Dwarf); 519 Off := TOnodes.Table (Atype); 520 pragma Assert (Off /= Null_Pc); 521 Gen_32 (Unsigned_32 (Off)); 522 end Emit_Type_Ref; 523 524 procedure Emit_Ident (Id : O_Ident) 525 is 526 use Ortho_Ident; 527 L : Natural; 528 begin 529 L := Get_String_Length (Id); 530 Prealloc (Pc_Type (L) + 128); 531 Gen_String_Nul (Get_String (Id)); 532 end Emit_Ident; 533 534 procedure Add_Type_Ref (Atype : O_Tnode; Pc : Pc_Type) 535 is 536 Prev : O_Tnode; 537 begin 538 if Atype > TOnodes.Last then 539 -- Expand. 540 Prev := TOnodes.Last; 541 TOnodes.Set_Last (Atype); 542 TOnodes.Table (Prev + 1 .. Atype - 1) := (others => Null_Pc); 543 end if; 544 TOnodes.Table (Atype) := Pc; 545 end Add_Type_Ref; 546 547 procedure Emit_Decl_Ident (Decl : O_Dnode) 548 is 549 use Ortho_Code.Decls; 550 begin 551 Emit_Ident (Get_Decl_Ident (Decl)); 552 end Emit_Decl_Ident; 553 554 procedure Emit_Decl_Ident_If_Set (Decl : O_Dnode) 555 is 556 use Ortho_Code.Decls; 557 begin 558 if Decl /= O_Dnode_Null then 559 Emit_Ident (Get_Decl_Ident (Decl)); 560 end if; 561 end Emit_Decl_Ident_If_Set; 562 563 procedure Emit_Type (Atype : O_Tnode); 564 565 procedure Emit_Base_Type (Atype : O_Tnode; Decl : O_Dnode) 566 is 567 use Ortho_Code.Types; 568 procedure Finish_Gen_Abbrev is 569 begin 570 Gen_Abbrev_Tuple (DW_AT_Encoding, DW_FORM_Data1); 571 Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); 572 Gen_Abbrev_Tuple (0, 0); 573 end Finish_Gen_Abbrev; 574 begin 575 if Decl = O_Dnode_Null then 576 if Abbrev_Base_Type = 0 then 577 Generate_Abbrev (Abbrev_Base_Type); 578 Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No); 579 Finish_Gen_Abbrev; 580 end if; 581 Gen_Info_Header (Abbrev_Base_Type); 582 else 583 if Abbrev_Base_Type_Name = 0 then 584 Generate_Abbrev (Abbrev_Base_Type_Name); 585 Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No); 586 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 587 Finish_Gen_Abbrev; 588 end if; 589 Gen_Info_Header (Abbrev_Base_Type_Name); 590 Emit_Decl_Ident (Decl); 591 end if; 592 593 case Get_Type_Kind (Atype) is 594 when OT_Signed => 595 Gen_8 (DW_ATE_Signed); 596 when OT_Unsigned => 597 Gen_8 (DW_ATE_Unsigned); 598 when OT_Float => 599 Gen_8 (DW_ATE_Float); 600 when others => 601 raise Program_Error; 602 end case; 603 Gen_8 (Byte (Get_Type_Size (Atype))); 604 end Emit_Base_Type; 605 606 procedure Emit_Access_Type (Atype : O_Tnode; Decl : O_Dnode) 607 is 608 use Ortho_Code.Types; 609 procedure Finish_Gen_Abbrev is 610 begin 611 Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); 612 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 613 Gen_Abbrev_Tuple (0, 0); 614 end Finish_Gen_Abbrev; 615 616 procedure Finish_Gen_Abbrev_Uncomplete is 617 begin 618 Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); 619 Gen_Abbrev_Tuple (0, 0); 620 end Finish_Gen_Abbrev_Uncomplete; 621 622 Dtype : O_Tnode; 623 D_Pc : Pc_Type; 624 begin 625 Dtype := Get_Type_Access_Type (Atype); 626 627 if Dtype = O_Tnode_Null then 628 if Decl = O_Dnode_Null then 629 if Abbrev_Uncomplete_Pointer = 0 then 630 Generate_Abbrev (Abbrev_Uncomplete_Pointer); 631 Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); 632 Finish_Gen_Abbrev_Uncomplete; 633 end if; 634 Gen_Info_Header (Abbrev_Uncomplete_Pointer); 635 else 636 if Abbrev_Uncomplete_Pointer_Name = 0 then 637 Generate_Abbrev (Abbrev_Uncomplete_Pointer_Name); 638 Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); 639 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 640 Finish_Gen_Abbrev_Uncomplete; 641 end if; 642 Gen_Info_Header (Abbrev_Uncomplete_Pointer_Name); 643 Emit_Decl_Ident (Decl); 644 end if; 645 Gen_8 (Byte (Get_Type_Size (Atype))); 646 else 647 if Decl = O_Dnode_Null then 648 if Abbrev_Pointer = 0 then 649 Generate_Abbrev (Abbrev_Pointer); 650 Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); 651 Finish_Gen_Abbrev; 652 end if; 653 Gen_Info_Header (Abbrev_Pointer); 654 else 655 if Abbrev_Pointer_Name = 0 then 656 Generate_Abbrev (Abbrev_Pointer_Name); 657 Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No); 658 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 659 Finish_Gen_Abbrev; 660 end if; 661 Gen_Info_Header (Abbrev_Pointer_Name); 662 Emit_Decl_Ident (Decl); 663 end if; 664 Gen_8 (Byte (Get_Type_Size (Atype))); 665 -- Break possible loops: generate the access entry... 666 D_Pc := Get_Current_Pc; 667 Gen_32 (0); 668 -- ... generate the designated type ... 669 Emit_Type (Dtype); 670 -- ... and write its reference. 671 Patch_32 (D_Pc, Unsigned_32 (TOnodes.Table (Dtype))); 672 end if; 673 end Emit_Access_Type; 674 675 procedure Emit_Array_Type 676 (Decl : O_Dnode; El_Type : O_Tnode; Idx_Type : O_Tnode) 677 is 678 procedure Finish_Gen_Abbrev is 679 begin 680 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 681 Gen_Abbrev_Tuple (0, 0); 682 end Finish_Gen_Abbrev; 683 begin 684 if Decl = O_Dnode_Null then 685 if Abbrev_Ucarray = 0 then 686 Generate_Abbrev (Abbrev_Ucarray); 687 Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); 688 Finish_Gen_Abbrev; 689 end if; 690 Gen_Info_Header (Abbrev_Ucarray); 691 else 692 if Abbrev_Ucarray_Name = 0 then 693 Generate_Abbrev (Abbrev_Ucarray_Name); 694 Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); 695 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 696 Finish_Gen_Abbrev; 697 end if; 698 Gen_Info_Header (Abbrev_Ucarray_Name); 699 Emit_Decl_Ident (Decl); 700 end if; 701 Emit_Type_Ref (El_Type); 702 703 if Abbrev_Uc_Subrange = 0 then 704 Generate_Abbrev (Abbrev_Uc_Subrange); 705 Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No); 706 707 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 708 Gen_Abbrev_Tuple (0, 0); 709 end if; 710 711 Gen_Info_Header (Abbrev_Uc_Subrange); 712 Emit_Type_Ref (Idx_Type); 713 714 Gen_Uleb128 (0); 715 end Emit_Array_Type; 716 717 procedure Emit_Ucarray_Type (Atype : O_Tnode; Decl : O_Dnode) 718 is 719 use Ortho_Code.Types; 720 begin 721 Emit_Array_Type (Decl, 722 Get_Type_Ucarray_Element (Atype), 723 Get_Type_Ucarray_Index (Atype)); 724 end Emit_Ucarray_Type; 725 726 procedure Emit_Subarray_Type (Atype : O_Tnode; Decl : O_Dnode) 727 is 728 use Ortho_Code.Types; 729 procedure Finish_Gen_Abbrev is 730 begin 731 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 732 Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); 733 Gen_Abbrev_Tuple (0, 0); 734 end Finish_Gen_Abbrev; 735 736 Base : O_Tnode; 737 begin 738 if Decl = O_Dnode_Null then 739 if Abbrev_Subarray = 0 then 740 Generate_Abbrev (Abbrev_Subarray); 741 Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); 742 Finish_Gen_Abbrev; 743 end if; 744 Gen_Info_Header (Abbrev_Subarray); 745 else 746 if Abbrev_Subarray_Name = 0 then 747 Generate_Abbrev (Abbrev_Subarray_Name); 748 Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes); 749 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 750 Finish_Gen_Abbrev; 751 end if; 752 Gen_Info_Header (Abbrev_Subarray_Name); 753 Emit_Decl_Ident (Decl); 754 end if; 755 756 757 Emit_Type_Ref (Get_Type_Subarray_Element (Atype)); 758 Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype))); 759 760 if Abbrev_Subrange = 0 then 761 Generate_Abbrev (Abbrev_Subrange); 762 Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No); 763 764 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 765 Gen_Abbrev_Tuple (DW_AT_Lower_Bound, DW_FORM_Data1); 766 Gen_Abbrev_Tuple (DW_AT_Count, DW_FORM_Udata); 767 Gen_Abbrev_Tuple (0, 0); 768 end if; 769 770 Gen_Info_Header (Abbrev_Subrange); 771 Base := Get_Type_Subarray_Base (Atype); 772 Emit_Type_Ref (Get_Type_Ucarray_Index (Base)); 773 Gen_8 (0); 774 Gen_Uleb128 (Unsigned_32 (Get_Type_Subarray_Length (Atype))); 775 776 Gen_Uleb128 (0); 777 end Emit_Subarray_Type; 778 779 procedure Emit_Members (Atype : O_Tnode; Decl : O_Dnode) 780 is 781 use Ortho_Code.Types; 782 Nbr : Uns32; 783 F : O_Fnode; 784 Loc_Pc : Pc_Type; 785 Sibling_Pc : Pc_Type; 786 Sz : Uns32; 787 begin 788 if Abbrev_Member = 0 then 789 Generate_Abbrev (Abbrev_Member); 790 791 Gen_Abbrev_Header (DW_TAG_Member, DW_CHILDREN_No); 792 793 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 794 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 795 Gen_Abbrev_Tuple (DW_AT_Data_Member_Location, DW_FORM_Block1); 796 Gen_Abbrev_Tuple (0, 0); 797 end if; 798 799 Set_Current_Section (Info_Sect); 800 Sibling_Pc := Gen_Info_Sibling; 801 Emit_Decl_Ident_If_Set (Decl); 802 if Get_Type_Sized (Atype) then 803 Sz := Get_Type_Size (Atype); 804 else 805 Sz := Get_Type_Record_Size (Atype); 806 end if; 807 Gen_Uleb128 (Unsigned_32 (Sz)); 808 809 Nbr := Get_Type_Record_Nbr_Fields (Atype); 810 F := Get_Type_Record_Fields (Atype); 811 while Nbr > 0 loop 812 Gen_Uleb128 (Abbrev_Member); 813 Emit_Ident (Get_Field_Ident (F)); 814 Emit_Type_Ref (Get_Field_Type (F)); 815 816 -- Location. 817 Loc_Pc := Get_Current_Pc; 818 Gen_8 (3); 819 Gen_8 (DW_OP_Plus_Uconst); 820 Gen_Uleb128 (Unsigned_32 (Get_Field_Offset (F))); 821 Patch_8 (Loc_Pc, Unsigned_8 (Get_Current_Pc - (Loc_Pc + 1))); 822 823 F := Get_Field_Chain (F); 824 Nbr := Nbr - 1; 825 end loop; 826 827 -- end of children. 828 Gen_Uleb128 (0); 829 Patch_Info_Sibling (Sibling_Pc); 830 end Emit_Members; 831 832 procedure Emit_Record_Type (Atype : O_Tnode; Decl : O_Dnode) 833 is 834 procedure Finish_Gen_Abbrev is 835 begin 836 Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); 837 Gen_Abbrev_Tuple (0, 0); 838 end Finish_Gen_Abbrev; 839 begin 840 if Decl = O_Dnode_Null then 841 if Abbrev_Struct = 0 then 842 Generate_Abbrev (Abbrev_Struct); 843 844 Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes); 845 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 846 Finish_Gen_Abbrev; 847 end if; 848 Gen_Info_Header (Abbrev_Struct); 849 else 850 if Abbrev_Struct_Name = 0 then 851 Generate_Abbrev (Abbrev_Struct_Name); 852 853 Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes); 854 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 855 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 856 Finish_Gen_Abbrev; 857 end if; 858 Gen_Info_Header (Abbrev_Struct_Name); 859 end if; 860 Emit_Members (Atype, Decl); 861 end Emit_Record_Type; 862 863 procedure Emit_Union_Type (Atype : O_Tnode; Decl : O_Dnode) 864 is 865 procedure Finish_Gen_Abbrev is 866 begin 867 Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata); 868 Gen_Abbrev_Tuple (0, 0); 869 end Finish_Gen_Abbrev; 870 begin 871 if Decl = O_Dnode_Null then 872 if Abbrev_Union = 0 then 873 Generate_Abbrev (Abbrev_Union); 874 875 Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes); 876 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 877 Finish_Gen_Abbrev; 878 end if; 879 Gen_Info_Header (Abbrev_Union); 880 else 881 if Abbrev_Union_Name = 0 then 882 Generate_Abbrev (Abbrev_Union_Name); 883 884 Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes); 885 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 886 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 887 Finish_Gen_Abbrev; 888 end if; 889 Gen_Info_Header (Abbrev_Union_Name); 890 end if; 891 Emit_Members (Atype, Decl); 892 end Emit_Union_Type; 893 894 procedure Emit_Enum_Type (Atype : O_Tnode; Decl : O_Dnode) 895 is 896 use Ortho_Code.Types; 897 use Ortho_Code.Consts; 898 procedure Finish_Gen_Abbrev is 899 begin 900 Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1); 901 Gen_Abbrev_Tuple (0, 0); 902 end Finish_Gen_Abbrev; 903 904 procedure Emit_Enumerator (L : O_Cnode) is 905 begin 906 Gen_Uleb128 (Abbrev_Enumerator); 907 Emit_Ident (Get_Lit_Ident (L)); 908 Gen_Uleb128 (Unsigned_32 (Get_Lit_Value (L))); 909 end Emit_Enumerator; 910 911 Nbr : Uns32; 912 L : O_Cnode; 913 Sibling_Pc : Pc_Type; 914 begin 915 if Abbrev_Enumerator = 0 then 916 Generate_Abbrev (Abbrev_Enumerator); 917 918 Gen_Abbrev_Header (DW_TAG_Enumerator, DW_CHILDREN_No); 919 920 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 921 Gen_Abbrev_Tuple (DW_AT_Const_Value, DW_FORM_Udata); 922 Gen_Abbrev_Tuple (0, 0); 923 end if; 924 if Decl = O_Dnode_Null then 925 if Abbrev_Enum = 0 then 926 Generate_Abbrev (Abbrev_Enum); 927 Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes); 928 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 929 Finish_Gen_Abbrev; 930 end if; 931 Gen_Info_Header (Abbrev_Enum); 932 else 933 if Abbrev_Enum_Name = 0 then 934 Generate_Abbrev (Abbrev_Enum_Name); 935 Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes); 936 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 937 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 938 Finish_Gen_Abbrev; 939 end if; 940 Gen_Info_Header (Abbrev_Enum_Name); 941 end if; 942 943 Sibling_Pc := Gen_Info_Sibling; 944 Emit_Decl_Ident_If_Set (Decl); 945 Gen_8 (Byte (Get_Type_Size (Atype))); 946 case Get_Type_Kind (Atype) is 947 when OT_Enum => 948 Nbr := Get_Type_Enum_Nbr_Lits (Atype); 949 L := Get_Type_Enum_Lits (Atype); 950 while Nbr > 0 loop 951 Emit_Enumerator (L); 952 953 L := Get_Lit_Chain (L); 954 Nbr := Nbr - 1; 955 end loop; 956 when OT_Boolean => 957 Emit_Enumerator (Get_Type_Bool_False (Atype)); 958 Emit_Enumerator (Get_Type_Bool_True (Atype)); 959 when others => 960 raise Program_Error; 961 end case; 962 963 -- End of children. 964 Gen_Uleb128 (0); 965 Patch_Info_Sibling (Sibling_Pc); 966 end Emit_Enum_Type; 967 968 procedure Emit_Type (Atype : O_Tnode) 969 is 970 use Ortho_Code.Types; 971 Kind : OT_Kind; 972 Decl : O_Dnode; 973 begin 974 if Flag_Debug < Debug_Dwarf then 975 return; 976 end if; 977 978 -- If already emitted, then return. 979 if Atype <= TOnodes.Last 980 and then TOnodes.Table (Atype) /= Null_Pc 981 then 982 return; 983 end if; 984 985 Kind := Get_Type_Kind (Atype); 986 987 -- First step: emit inner types (if any). 988 case Kind is 989 when OT_Signed 990 | OT_Unsigned 991 | OT_Float 992 | OT_Boolean 993 | OT_Enum => 994 null; 995 when OT_Access => 996 null; 997 when OT_Ucarray => 998 Emit_Type (Get_Type_Ucarray_Index (Atype)); 999 Emit_Type (Get_Type_Ucarray_Element (Atype)); 1000 when OT_Subarray => 1001 Emit_Type (Get_Type_Subarray_Base (Atype)); 1002 when OT_Record 1003 | OT_Subrecord 1004 | OT_Union => 1005 declare 1006 Nbr : Uns32; 1007 F : O_Fnode; 1008 begin 1009 Nbr := Get_Type_Record_Nbr_Fields (Atype); 1010 F := Get_Type_Record_Fields (Atype); 1011 while Nbr > 0 loop 1012 Emit_Type (Get_Field_Type (F)); 1013 F := Get_Field_Chain (F); 1014 Nbr := Nbr - 1; 1015 end loop; 1016 end; 1017 when OT_Complete => 1018 null; 1019 end case; 1020 1021 Set_Current_Section (Info_Sect); 1022 Add_Type_Ref (Atype, Get_Current_Pc); 1023 1024 Decl := Decls.Get_Type_Decl (Atype); 1025 1026 -- Second step: emit info. 1027 case Kind is 1028 when OT_Signed 1029 | OT_Unsigned 1030 | OT_Float => 1031 Emit_Base_Type (Atype, Decl); 1032 -- base types. 1033 when OT_Access => 1034 Emit_Access_Type (Atype, Decl); 1035 when OT_Ucarray => 1036 Emit_Ucarray_Type (Atype, Decl); 1037 when OT_Subarray => 1038 Emit_Subarray_Type (Atype, Decl); 1039 when OT_Record 1040 | OT_Subrecord => 1041 Emit_Record_Type (Atype, Decl); 1042 when OT_Union => 1043 Emit_Union_Type (Atype, Decl); 1044 when OT_Enum 1045 | OT_Boolean => 1046 Emit_Enum_Type (Atype, Decl); 1047 when OT_Complete => 1048 null; 1049 end case; 1050 end Emit_Type; 1051 1052 procedure Emit_Decl_Type (Decl : O_Dnode) 1053 is 1054 use Ortho_Code.Decls; 1055 begin 1056 Emit_Type_Ref (Get_Decl_Type (Decl)); 1057 end Emit_Decl_Type; 1058 1059 Abbrev_Variable : Unsigned_32 := 0; 1060 Abbrev_Const : Unsigned_32 := 0; 1061 1062 procedure Emit_Local_Location (Decl : O_Dnode) 1063 is 1064 use Ortho_Code.Decls; 1065 Pc : Pc_Type; 1066 begin 1067 Pc := Get_Current_Pc; 1068 Gen_8 (2); 1069 Gen_8 (DW_OP_Fbreg); 1070 Gen_Sleb128 (Get_Decl_Info (Decl)); 1071 Patch_8 (Pc, Unsigned_8 (Get_Current_Pc - (Pc + 1))); 1072 end Emit_Local_Location; 1073 1074 procedure Emit_Global_Location (Decl : O_Dnode) 1075 is 1076 use Ortho_Code.Binary; 1077 begin 1078 Gen_8 (1 + Pc_Type_Sizeof); 1079 Gen_8 (DW_OP_Addr); 1080 Gen_Ua_Addr (Get_Decl_Symbol (Decl), 0); 1081 end Emit_Global_Location; 1082 1083 procedure Emit_Variable (Decl : O_Dnode) 1084 is 1085 use Ortho_Code.Decls; 1086 Dtype : O_Tnode; 1087 begin 1088 if Get_Decl_Ident (Decl) = O_Ident_Nul then 1089 return; 1090 end if; 1091 1092 if Abbrev_Variable = 0 then 1093 Generate_Abbrev (Abbrev_Variable); 1094 Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No); 1095 1096 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 1097 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 1098 Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); 1099 Gen_Abbrev_Tuple (0, 0); 1100 end if; 1101 1102 Dtype := Get_Decl_Type (Decl); 1103 Emit_Type (Dtype); 1104 1105 Gen_Info_Header (Abbrev_Variable); 1106 Emit_Decl_Ident (Decl); 1107 Emit_Type_Ref (Dtype); 1108 case Get_Decl_Kind (Decl) is 1109 when OD_Local => 1110 Emit_Local_Location (Decl); 1111 when OD_Var => 1112 Emit_Global_Location (Decl); 1113 when others => 1114 raise Program_Error; 1115 end case; 1116 end Emit_Variable; 1117 1118 procedure Emit_Const (Decl : O_Dnode) 1119 is 1120 use Ortho_Code.Decls; 1121 Dtype : O_Tnode; 1122 begin 1123 if Abbrev_Const = 0 then 1124 Generate_Abbrev (Abbrev_Const); 1125 -- FIXME: should be a TAG_Constant, however, GDB does not support it. 1126 -- work-around: could use a const_type. 1127 Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No); 1128 1129 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 1130 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 1131 Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); 1132 Gen_Abbrev_Tuple (0, 0); 1133 end if; 1134 1135 Dtype := Get_Decl_Type (Decl); 1136 Emit_Type (Dtype); 1137 Gen_Info_Header (Abbrev_Const); 1138 Emit_Decl_Ident (Decl); 1139 Emit_Type_Ref (Dtype); 1140 Emit_Global_Location (Decl); 1141 end Emit_Const; 1142 1143 procedure Emit_Type_Decl (Decl : O_Dnode) 1144 is 1145 use Ortho_Code.Decls; 1146 begin 1147 Emit_Type (Get_Decl_Type (Decl)); 1148 end Emit_Type_Decl; 1149 1150 Subprg_Sym : Symbol; 1151 1152 Abbrev_Block : Unsigned_32 := 0; 1153 1154 procedure Emit_Block_Decl (Decl : O_Dnode) 1155 is 1156 use Ortho_Code.Decls; 1157 Last : O_Dnode; 1158 Sdecl : O_Dnode; 1159 Sibling_Pc : Pc_Type; 1160 begin 1161 if Flag_Debug >= Debug_Dwarf then 1162 if Abbrev_Block = 0 then 1163 Generate_Abbrev (Abbrev_Block); 1164 1165 Gen_Abbrev_Header (DW_TAG_Lexical_Block, DW_CHILDREN_Yes); 1166 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 1167 Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); 1168 Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); 1169 Gen_Abbrev_Tuple (0, 0); 1170 end if; 1171 1172 Gen_Info_Header (Abbrev_Block); 1173 Sibling_Pc := Gen_Info_Sibling; 1174 1175 Gen_Ua_Addr (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl))); 1176 Gen_Ua_Addr (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl))); 1177 end if; 1178 1179 -- Emit decls for children. 1180 Last := Get_Block_Last (Decl); 1181 Sdecl := Decl + 1; 1182 while Sdecl <= Last loop 1183 Emit_Decl (Sdecl); 1184 Sdecl := Get_Decl_Chain (Sdecl); 1185 end loop; 1186 1187 if Flag_Debug >= Debug_Dwarf then 1188 -- End of children. 1189 Set_Current_Section (Info_Sect); 1190 Gen_Uleb128 (0); 1191 1192 Patch_Info_Sibling (Sibling_Pc); 1193 end if; 1194 end Emit_Block_Decl; 1195 1196 Abbrev_Function : Unsigned_32 := 0; 1197 Abbrev_Procedure : Unsigned_32 := 0; 1198 Abbrev_Interface : Unsigned_32 := 0; 1199 1200 procedure Emit_Subprg_Body (Bod : O_Dnode) 1201 is 1202 use Ortho_Code.Decls; 1203 Decl : constant O_Dnode := Get_Body_Decl (Bod); 1204 Kind : constant OD_Kind := Get_Decl_Kind (Decl); 1205 Idecl : O_Dnode; 1206 Prev_Subprg_Sym : Symbol; 1207 Sibling_Pc : Pc_Type; 1208 begin 1209 -- Emit interfaces type. 1210 Idecl := Get_Subprg_Interfaces (Decl); 1211 while Idecl /= O_Dnode_Null loop 1212 Emit_Type (Get_Decl_Type (Idecl)); 1213 Idecl := Get_Interface_Chain (Idecl); 1214 end loop; 1215 1216 if Kind = OD_Function then 1217 Emit_Type (Get_Decl_Type (Decl)); 1218 if Abbrev_Function = 0 then 1219 Generate_Abbrev (Abbrev_Function); 1220 1221 Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes); 1222 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 1223 Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); 1224 Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); 1225 1226 if Flag_Debug >= Debug_Dwarf then 1227 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 1228 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 1229 Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); 1230 end if; 1231 --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); 1232 Gen_Abbrev_Tuple (0, 0); 1233 end if; 1234 Gen_Info_Header (Abbrev_Function); 1235 else 1236 if Abbrev_Procedure = 0 then 1237 Generate_Abbrev (Abbrev_Procedure); 1238 1239 Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes); 1240 1241 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 1242 Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr); 1243 Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr); 1244 if Flag_Debug >= Debug_Dwarf then 1245 Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4); 1246 Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1); 1247 end if; 1248 --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1); 1249 Gen_Abbrev_Tuple (0, 0); 1250 end if; 1251 Gen_Info_Header (Abbrev_Procedure); 1252 end if; 1253 1254 -- Name. 1255 Emit_Decl_Ident (Decl); 1256 1257 -- Low, High. 1258 Prev_Subprg_Sym := Subprg_Sym; 1259 Subprg_Sym := Binary.Get_Decl_Symbol (Decl); 1260 Gen_Ua_Addr (Subprg_Sym, 0); 1261 Gen_Ua_Addr (Subprg_Sym, Integer_32 (Get_Body_Info (Bod))); 1262 1263 if Flag_Debug >= Debug_Dwarf then 1264 -- Type. 1265 if Kind = OD_Function then 1266 Emit_Decl_Type (Decl); 1267 end if; 1268 1269 -- Sibling. 1270 Sibling_Pc := Gen_Info_Sibling; 1271 1272 -- Frame base. 1273 Gen_8 (1); 1274 case Arch is 1275 when Arch_X86 => 1276 Gen_8 (DW_OP_Reg5); -- ebp 1277 when Arch_X86_64 => 1278 Gen_8 (DW_OP_Reg6); -- rbp 1279 when others => 1280 raise Program_Error; 1281 end case; 1282 end if; 1283 1284 -- Interfaces. 1285 Idecl := Get_Subprg_Interfaces (Decl); 1286 if Idecl /= O_Dnode_Null 1287 and then Flag_Debug >= Debug_Dwarf 1288 then 1289 if Abbrev_Interface = 0 then 1290 Generate_Abbrev (Abbrev_Interface); 1291 1292 Gen_Abbrev_Header (DW_TAG_Formal_Parameter, DW_CHILDREN_No); 1293 Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4); 1294 Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String); 1295 Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1); 1296 Gen_Abbrev_Tuple (0, 0); 1297 end if; 1298 1299 loop 1300 Gen_Info_Header (Abbrev_Interface); 1301 Emit_Decl_Type (Idecl); 1302 Emit_Decl_Ident (Idecl); 1303 1304 Emit_Local_Location (Idecl); 1305 1306 Idecl := Get_Interface_Chain (Idecl); 1307 exit when Idecl = O_Dnode_Null; 1308 end loop; 1309 end if; 1310 1311 -- Internal declarations. 1312 Emit_Block_Decl (Bod + 1); 1313 1314 -- End of children. 1315 Gen_Uleb128 (0); 1316 1317 if Flag_Debug >= Debug_Dwarf then 1318 Patch_Info_Sibling (Sibling_Pc); 1319 end if; 1320 1321 Subprg_Sym := Prev_Subprg_Sym; 1322 end Emit_Subprg_Body; 1323 1324 procedure Emit_Decl (Decl : O_Dnode) 1325 is 1326 use Ada.Text_IO; 1327 use Ortho_Code.Decls; 1328 begin 1329 if Flag_Debug = Debug_Dwarf then 1330 case Get_Decl_Kind (Decl) is 1331 when OD_Type => 1332 Emit_Type_Decl (Decl); 1333 when OD_Local 1334 | OD_Var => 1335 Emit_Variable (Decl); 1336 when OD_Const => 1337 Emit_Const (Decl); 1338 when OD_Function 1339 | OD_Procedure 1340 | OD_Interface => 1341 null; 1342 when OD_Body => 1343 Emit_Subprg_Body (Decl); 1344 when OD_Block => 1345 Emit_Block_Decl (Decl); 1346 when others => 1347 Put_Line ("dwarf.emit_decl: emit " 1348 & OD_Kind'Image (Get_Decl_Kind (Decl))); 1349 end case; 1350 elsif Flag_Debug = Debug_Line then 1351 if Get_Decl_Kind (Decl) = OD_Body then 1352 Emit_Subprg_Body (Decl); 1353 end if; 1354 end if; 1355 end Emit_Decl; 1356 1357 procedure Emit_Subprg (Bod : O_Dnode) is 1358 begin 1359 Emit_Decls_Until (Bod); 1360 Emit_Decl (Bod); 1361 Last_Decl := Decls.Get_Decl_Chain (Bod); 1362 end Emit_Subprg; 1363 1364 procedure Mark (M : out Mark_Type) is 1365 begin 1366 M.Last_Decl := Last_Decl; 1367 M.Last_Tnode := TOnodes.Last; 1368 end Mark; 1369 1370 procedure Release (M : Mark_Type) is 1371 begin 1372 Last_Decl := M.Last_Decl; 1373 TOnodes.Set_Last (M.Last_Tnode); 1374 end Release; 1375 1376end Ortho_Code.Dwarf; 1377