Add symbolizer (for mcode).

Display a backtrace in case of failed check or assert failure.

1 files changed, 655 insertions, 0 deletions

diff --git a/src/ortho/mcode/symbolizer.adb b/src/ortho/mcode/symbolizer.adb
new file mode 100644
index 0000000..79e7de2
--- /dev/null
+++ b/src/ortho/mcode/symbolizer.adb
@@ -0,0 +1,655 @@
+--  Dwarf symbolizer.
+--  Copyright (C) 2015 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 Ada.Unchecked_Conversion;
+with Interfaces; use Interfaces;
+with Dwarf; use Dwarf;
+
+package body Symbolizer is
+   type Abbrev_Array is array (Unsigned_32 range <>) of Address;
+   type Abbrev_Array_Acc is access Abbrev_Array;
+
+   --  Data for decoding abbrevs.
+   --  Abbrevs are referenced by its number, but it is not possible to directly
+   --  reference an abbrev from its number.  A map is required.
+   --  The main purpose of these data is to build the map.
+   type Abbrev_Data is record
+      --  Static map.  Mcode doesn't generate a lot of abbrev.
+      Sarray : Abbrev_Array (1 .. 64);
+      --  First non-decoded abbrev.
+      Next_Num : Unsigned_32;
+      --  Address (in .debug_abbrev section) of the next abbrev to be decoded.
+      Next_Addr : Address;
+      --  Address of the first byte after the abbrev section.  Used to not read
+      --  past the section.
+      Last_Addr : Address;
+      --  If there are too many abbrevs, use a resizable array instead of the
+      --  static one.
+      Map : Abbrev_Array_Acc;
+   end record;
+
+   function Read_Byte (Addr : Address) return Unsigned_8
+   is
+      type Unsigned_8_Acc is access all Unsigned_8;
+      function To_Unsigned_8_Acc is new Ada.Unchecked_Conversion
+        (Address, Unsigned_8_Acc);
+   begin
+      return To_Unsigned_8_Acc (Addr).all;
+   end Read_Byte;
+
+   procedure Read_Word4 (Addr : in out Address;
+                         Res : out Unsigned_32)
+   is
+      B0, B1, B2, B3 : Unsigned_8;
+   begin
+      B0 := Read_Byte (Addr + 0);
+      B1 := Read_Byte (Addr + 1);
+      B2 := Read_Byte (Addr + 2);
+      B3 := Read_Byte (Addr + 3);
+      --  FIXME: we assume little-endian
+      Res := Shift_Left (Unsigned_32 (B3), 24)
+        or Shift_Left (Unsigned_32 (B2), 16)
+        or Shift_Left (Unsigned_32 (B1), 8)
+        or Shift_Left (Unsigned_32 (B0), 0);
+      Addr := Addr + 4;
+   end Read_Word4;
+
+   procedure Read_Word2 (Addr : in out Address;
+                         Res : out Unsigned_16)
+   is
+      B0, B1 : Unsigned_8;
+   begin
+      B0 := Read_Byte (Addr + 0);
+      B1 := Read_Byte (Addr + 1);
+      --  FIXME: we assume little-endian
+      Res := Shift_Left (Unsigned_16 (B1), 8)
+        or Shift_Left (Unsigned_16 (B0), 0);
+      Addr := Addr + 2;
+   end Read_Word2;
+
+   procedure Read_Byte (Addr : in out Address;
+                        Res : out Unsigned_8)
+   is
+   begin
+      Res := Read_Byte (Addr);
+      Addr := Addr + 1;
+   end Read_Byte;
+
+   procedure Read_ULEB128 (Addr : in out Address;
+                           Res : out Unsigned_32)
+   is
+      B : Unsigned_8;
+      Shift : Integer;
+   begin
+      Res := 0;
+      Shift := 0;
+      loop
+         B := Read_Byte (Addr);
+         Addr := Addr + 1;
+         Res := Res or Shift_Left (Unsigned_32 (B and 16#7f#), Shift);
+         exit when (B and 16#80#) = 0;
+         Shift := Shift + 7;
+      end loop;
+   end Read_ULEB128;
+
+   procedure Read_SLEB128 (Addr : in out Address;
+                           Res : out Unsigned_32)
+   is
+      B : Unsigned_8;
+      Shift : Integer;
+   begin
+      Res := 0;
+      Shift := 0;
+      loop
+         B := Read_Byte (Addr);
+         Addr := Addr + 1;
+         Res := Res or Shift_Left (Unsigned_32 (B and 16#7f#), Shift);
+         Shift := Shift + 7;
+         exit when (B and 16#80#) = 0;
+      end loop;
+      if Shift < 32 and (Res and Shift_Left (1, Shift - 1)) /= 0 then
+         Res := Res or Shift_Left (-1, Shift);
+      end if;
+   end Read_SLEB128;
+
+   procedure Init_Abbrev (Abbrevs : in out Abbrev_Data;
+                          Sections : Dwarf_Sections;
+                          Off : Storage_Offset)
+   is
+      Old_Map : Abbrev_Array_Acc;
+   begin
+      Old_Map := Abbrevs.Map;
+      if Old_Map /= null then
+         Old_Map.all := (others => Null_Address);
+      end if;
+
+      Abbrevs := (Sarray => (others => Null_Address),
+                  Next_Num => 0,
+                  Next_Addr => Sections.Debug_Abbrev.Vaddr + Off,
+                  Last_Addr => (Sections.Debug_Abbrev.Vaddr
+                                  + Sections.Debug_Abbrev.Size),
+                  Map => Old_Map);
+   end Init_Abbrev;
+
+   procedure Find_Abbrev (Abbrevs : in out Abbrev_Data;
+                          Num : Unsigned_32;
+                          Res : out Address)
+   is
+      Code : Unsigned_32;
+      Addr : Address;
+      Tag, Name, Form : Unsigned_32;
+   begin
+      if Num > Abbrevs.Next_Num then
+         --  Not yet decoded.
+         Addr := Abbrevs.Next_Addr;
+
+         while Addr < Abbrevs.Last_Addr loop
+            --  Read abbreviation code.
+            Read_ULEB128 (Addr, Code);
+
+            if Code /= 0 then
+               --  Not a pad.
+
+               --  Insert address in map.
+               if Abbrevs.Map = null then
+                  if Code <= Abbrevs.Sarray'Last then
+                     Abbrevs.Sarray (Code) := Addr;
+                  else
+                     raise Program_Error;
+                  end if;
+               else
+                  if Code <= Abbrevs.Map'Last then
+                     Abbrevs.Map (Code) := Addr;
+                  else
+                     --  Need to expand map.
+                     raise Program_Error;
+                  end if;
+               end if;
+
+               --  Read tag.
+               Read_ULEB128 (Addr, Tag);
+
+               --  Skip child flag.
+               Addr := Addr + 1;
+
+               --  Skip attribute specifications.
+               loop
+                  Read_ULEB128 (Addr, Name);
+                  Read_ULEB128 (Addr, Form);
+                  exit when Name = 0 and Form = 0;
+               end loop;
+
+               --  Found.
+               exit when Code = Num;
+            end if;
+         end loop;
+
+         --  Next entry to read.
+         Abbrevs.Next_Addr := Addr;
+      end if;
+
+      --  Set result.
+      if Abbrevs.Map = null then
+         Res := Abbrevs.Sarray (Num);
+      else
+         Res := Abbrevs.Map (Num);
+      end if;
+   end Find_Abbrev;
+
+   procedure Read_Uns32 (Addr : in out Address;
+                         Form : Unsigned_32;
+                         Res : out Unsigned_32) is
+   begin
+      case Form is
+         when DW_FORM_Data4 =>
+            Read_Word4 (Addr, Res);
+         when others =>
+            raise Program_Error;
+      end case;
+   end Read_Uns32;
+
+   procedure Skip_String (Addr : in out Address) is
+   begin
+      while Read_Byte (Addr) /= 0 loop
+         Addr := Addr + 1;
+      end loop;
+      Addr := Addr + 1;
+   end Skip_String;
+
+   procedure Read_Addr (Addr : in out Address;
+                        Res : out Address)
+   is
+      function To_Address is new Ada.Unchecked_Conversion
+        (Unsigned_32, Address);
+      V : Unsigned_32;
+   begin
+      Read_Word4 (Addr, V);
+      Res := To_Address (V);
+   end Read_Addr;
+
+   procedure Read_Addr (Addr : in out Address;
+                        Form : Unsigned_32;
+                        Res : out Address)
+   is
+   begin
+      case Form is
+         when DW_FORM_Addr =>
+            Read_Addr (Addr, Res);
+         when DW_FORM_String =>
+            Res := Addr;
+            Skip_String (Addr);
+         when others =>
+            raise Program_Error;
+      end case;
+   end Read_Addr;
+
+   procedure Read_Ref (Addr : in out Address;
+                       Form : Unsigned_32;
+                       Base : Address;
+                       Res : out Address)
+   is
+      V : Unsigned_32;
+   begin
+      case Form is
+         when DW_FORM_Ref4 =>
+            Read_Word4 (Addr, V);
+            Res := Base + Storage_Offset (V);
+         when others =>
+            raise Program_Error;
+      end case;
+   end Read_Ref;
+
+   procedure Skip_Form (Addr : in out Address;
+                        Form : Unsigned_32)
+   is
+   begin
+      case Form is
+         when DW_FORM_Addr =>
+            Addr := Addr + 4;
+         when DW_FORM_Flag =>
+            Addr := Addr + 1;
+         when DW_FORM_Block1 =>
+            Addr := Addr + Storage_Offset (Read_Byte (Addr)) + 1;
+         when DW_FORM_Data1 =>
+            Addr := Addr + 1;
+         when DW_FORM_Data2 =>
+            Addr := Addr + 2;
+         when DW_FORM_Data4 =>
+            Addr := Addr + 4;
+         when DW_FORM_Sdata
+           | DW_FORM_Udata =>
+            while (Read_Byte (Addr) and 16#80#) /= 0 loop
+               Addr := Addr + 1;
+            end loop;
+            Addr := Addr + 1;
+         when DW_FORM_Ref4 =>
+            Addr := Addr + 4;
+         when DW_FORM_Strp =>
+            Addr := Addr + 4;
+         when DW_FORM_String =>
+            Skip_String (Addr);
+         when others =>
+            raise Program_Error;
+      end case;
+   end Skip_Form;
+
+   procedure Find_Subprogram (Pc : Address;
+                              Sections : Dwarf_Sections;
+                              Res : out Symbolize_Result;
+                              Abbrevs : in out Abbrev_Data;
+                              Unit_Stmt_List : out Unsigned_32)
+   is
+      Base : Address;
+      Addr : Address;
+      Sect_Last_Addr : Address;
+      Next_Unit_Addr : Address;
+
+      Abbrev : Address;
+
+      Unit_Len : Unsigned_32;
+      Ver : Unsigned_16;
+      Abbrev_Off : Unsigned_32;
+      Ptr_Sz : Unsigned_8;
+      Num : Unsigned_32;
+
+      Tag : Unsigned_32;
+      Abbrev_Name : Unsigned_32;
+      Abbrev_Form : Unsigned_32;
+
+      Level : Unsigned_8;
+
+      Stmt_List : Unsigned_32;
+      Low_Pc : Address;
+      High_Pc : Address;
+      Name : Address;
+      Sibling : Address;
+   begin
+      --  Initialize result.
+      Res := (Filename => Null_Address,
+              Line => 0,
+              Subprg_Name => Null_Address);
+
+      Addr := Sections.Debug_Info.Vaddr;
+      Sect_Last_Addr := Addr + Sections.Debug_Info.Size;
+
+      while Addr < Sect_Last_Addr loop
+         --  Read unit length.
+         Base := Addr;
+         Read_Word4 (Addr, Unit_Len);
+         Next_Unit_Addr := Addr + Storage_Offset (Unit_Len);
+         Read_Word2 (Addr, Ver);
+         Read_Word4 (Addr, Abbrev_Off);
+         Read_Byte (Addr, Ptr_Sz);
+         Level := 0;
+
+         Init_Abbrev (Abbrevs, Sections, Storage_Offset (Abbrev_Off));
+         Unit_Stmt_List := Unsigned_32'Last;
+
+         loop
+            << Again >> null;
+            exit when Addr >= Next_Unit_Addr;
+            --  Read abbrev number.
+            Read_ULEB128 (Addr, Num);
+
+            --  End of children.
+            if Num = 0 then
+               Level := Level - 1;
+               goto Again;
+            end if;
+
+            Find_Abbrev (Abbrevs, Num, Abbrev);
+            if Abbrev = Null_Address then
+               --  Not found...
+               return;
+            end if;
+
+            Read_ULEB128 (Abbrev, Tag);
+            if Read_Byte (Abbrev) /= 0 then
+               Level := Level + 1;
+            end if;
+
+            --  skip child.
+            Abbrev := Abbrev + 1;
+
+            --  We are only interested in a few attributes.
+            Stmt_List := Unsigned_32'Last;
+            Low_Pc := Null_Address;
+            High_Pc := Null_Address;
+            Name := Null_Address;
+            Sibling := Null_Address;
+
+            loop
+               Read_ULEB128 (Abbrev, Abbrev_Name);
+               Read_ULEB128 (Abbrev, Abbrev_Form);
+               exit when Abbrev_Name = 0 and Abbrev_Form = 0;
+               case Abbrev_Name is
+                  when DW_AT_Stmt_List =>
+                     Read_Uns32 (Addr, Abbrev_Form, Stmt_List);
+                  when DW_AT_Low_Pc =>
+                     Read_Addr (Addr, Abbrev_Form, Low_Pc);
+                  when DW_AT_High_Pc =>
+                     Read_Addr (Addr, Abbrev_Form, High_Pc);
+                  when DW_AT_Name =>
+                     Read_Addr (Addr, Abbrev_Form, Name);
+                  when DW_AT_Sibling =>
+                     Read_Ref (Addr, Abbrev_Form, Base, Sibling);
+                  when others =>
+                     Skip_Form (Addr, Abbrev_Form);
+               end case;
+            end loop;
+
+            case Tag is
+               when DW_TAG_Compile_Unit =>
+                  if Low_Pc /= Null_Address
+                    and then High_Pc /= Null_Address
+                    and then (Pc < Low_Pc or Pc > High_Pc)
+                  then
+                     --  Out of this compile unit.
+                     Addr := Next_Unit_Addr;
+                     exit;
+                  end if;
+                  Unit_Stmt_List := Stmt_List;
+               when DW_TAG_Subprogram =>
+                  if Low_Pc /= Null_Address
+                    and then High_Pc /= Null_Address
+                    and then (Pc >= Low_Pc and Pc <= High_Pc)
+                  then
+                     --  Found!
+                     Res.Subprg_Name := Name;
+                     return;
+                  end if;
+               when DW_TAG_Structure_Type
+                 | DW_TAG_Enumeration_Type =>
+                  if Sibling /= Null_Address then
+                     Addr := Sibling;
+                     Level := Level - 1;
+                  end if;
+               when others =>
+                  null;
+            end case;
+         end loop;
+      end loop;
+   end Find_Subprogram;
+
+   procedure Skip_Filename (Addr : in out Address)
+   is
+      File_Dir : Unsigned_32;
+      File_Time : Unsigned_32;
+      File_Len : Unsigned_32;
+   begin
+      Skip_String (Addr);
+      Read_ULEB128 (Addr, File_Dir);
+      Read_ULEB128 (Addr, File_Time);
+      Read_ULEB128 (Addr, File_Len);
+   end Skip_Filename;
+
+   procedure Find_Lineno (Pc_Addr : Address;
+                          Sections : Dwarf_Sections;
+                          Res : in out Symbolize_Result;
+                          Stmt_List : Storage_Offset)
+   is
+      Addr : Address;
+      Last_Addr : Address;
+      Next_Addr : Address;
+
+      --  Opcode length.  Use a fixed bound.
+      Opc_Length : array (Unsigned_8 range 1 .. 32) of Unsigned_8;
+
+      Total_Len : Unsigned_32;
+      Version : Unsigned_16;
+      Prolog_Len : Unsigned_32;
+      Min_Insn_Len : Unsigned_8;
+      Dflt_Is_Stmt : Unsigned_8;
+      Line_Base : Unsigned_8;
+      Line_Range : Unsigned_8;
+      Opc_Base : Unsigned_8;
+
+      B : Unsigned_8;
+      Arg : Unsigned_32;
+
+      File_Names : Address;
+
+      Ext_Len : Unsigned_32;
+      Ext_Opc : Unsigned_8;
+
+      Last : Address;
+
+      Pc : Address;
+      Line : Unsigned_32;
+      Line_Base2 : Unsigned_32;
+      New_Row : Boolean;
+
+      File_Id : Unsigned_32;
+      Prev_File_Id : Unsigned_32;
+      Prev_Pc : Address;
+      Prev_Line : Unsigned_32;
+   begin
+      if Stmt_List >= Sections.Debug_Line.Size then
+         --  Invalid stmt list.
+         return;
+      end if;
+      Addr := Sections.Debug_Line.Vaddr + Stmt_List;
+      Last_Addr := Addr + Sections.Debug_Line.Size - Stmt_List;
+
+      while Addr < Last_Addr loop
+         --  Read header.
+         Read_Word4 (Addr, Total_Len);
+         Last := Addr + Storage_Offset (Total_Len);
+         Read_Word2 (Addr, Version);
+         Read_Word4 (Addr, Prolog_Len);
+         Read_Byte (Addr, Min_Insn_Len);
+         Read_Byte (Addr, Dflt_Is_Stmt);
+         Read_Byte (Addr, Line_Base);
+         Read_Byte (Addr, Line_Range);
+         Read_Byte (Addr, Opc_Base);
+
+         Prev_Pc := Null_Address;
+         Prev_Line := 0;
+         Prev_File_Id := 0;
+         File_Id := 0;
+         New_Row := False;
+         Pc := Null_Address;
+         Line := 1;
+
+         --  Sign extend line base.
+         Line_Base2 := Unsigned_32 (Line_Base);
+         if (Line_Base and 16#80#) /= 0 then
+            Line_Base2 := Line_Base2 or 16#Ff_Ff_Ff_00#;
+         end if;
+
+         --  Read opcodes length.
+         if Opc_Base > Opc_Length'Last then
+            raise Program_Error;
+         end if;
+         for I in 1 .. Opc_Base - 1 loop
+            Read_Byte (Addr, B);
+            Opc_Length (I) := B;
+         end loop;
+
+         --  Include directories.
+         loop
+            B := Read_Byte (Addr);
+            exit when B = 0;
+            Skip_String (Addr);
+         end loop;
+         Addr := Addr + 1;
+
+         --  Filenames.
+         File_Names := Addr;
+         loop
+            B := Read_Byte (Addr);
+            exit when B = 0;
+            Skip_Filename (Addr);
+         end loop;
+         Addr := Addr + 1;
+
+         --  The debug_line 'program'.
+         while Addr < Last loop
+            --  Read opcode.
+            Read_Byte (Addr, B);
+
+            if B = 0 then
+               --  Extended opcode.
+               Read_ULEB128 (Addr, Ext_Len);
+               Next_Addr := Addr;
+               Read_Byte (Addr, Ext_Opc);
+               Next_Addr := Next_Addr + Storage_Offset (Ext_Len);
+               case Ext_Opc is
+                  when DW_LNE_End_Sequence =>
+                     New_Row := True;
+                  when DW_LNE_Set_Address =>
+                     Read_Addr (Addr, Pc);
+                  when others =>
+                     raise Program_Error;
+               end case;
+               pragma Assert (Addr = Next_Addr);
+            elsif B < Opc_Base then
+               --  Standard opcode.
+               case B is
+                  when DW_LNS_Copy =>
+                     New_Row := True;
+                  when DW_LNS_Advance_Pc =>
+                     Read_ULEB128 (Addr, Arg);
+                     Pc := Pc
+                       + Storage_Offset (Arg * Unsigned_32 (Min_Insn_Len));
+                  when DW_LNS_Advance_Line =>
+                     Read_SLEB128 (Addr, Arg);
+                     Line := Line + Arg;
+                  when DW_LNS_Const_Add_Pc =>
+                     Pc := Pc + Storage_Offset
+                       (Unsigned_32 ((255 - Opc_Base) / Line_Range)
+                          * Unsigned_32 (Min_Insn_Len));
+                  when DW_LNS_Set_File =>
+                     Read_ULEB128 (Addr, File_Id);
+                  when others =>
+                     for J in 1 .. Opc_Length (B) loop
+                        Read_ULEB128 (Addr, Arg);
+                     end loop;
+                     raise Program_Error;
+               end case;
+            else
+               --  Special opcode.
+               B := B - Opc_Base;
+               Pc := Pc + Storage_Offset
+                 (Unsigned_32 (B / Line_Range) * Unsigned_32 (Min_Insn_Len));
+               Line := Line + Line_Base2 + Unsigned_32 (B mod Line_Range);
+               New_Row := True;
+            end if;
+
+            if New_Row then
+               New_Row := False;
+               if Pc_Addr >= Prev_Pc and then Pc_Addr < Pc then
+                  Res.Line := Natural (Prev_Line);
+
+                  --  Search for filename.
+                  if Prev_File_Id = 0 then
+                     Addr := Null_Address;
+                  else
+                     Addr := File_Names;
+                     while Prev_File_Id > 1 loop
+                        exit when Read_Byte (Addr) = 0;
+                        Skip_Filename (Addr);
+                        Prev_File_Id := Prev_File_Id - 1;
+                     end loop;
+                  end if;
+                  Res.Filename := Addr;
+
+                  return;
+               end if;
+               Prev_Pc := Pc;
+               Prev_Line := Line;
+               Prev_File_Id := File_Id;
+            end if;
+         end loop;
+      end loop;
+   end Find_Lineno;
+
+   procedure Symbolize_Address (Pc : Address;
+                                Sections : Dwarf_Sections;
+                                Res : out Symbolize_Result)
+   is
+      Abbrevs : Abbrev_Data;
+      Unit_Stmt_List : Unsigned_32;
+   begin
+      Find_Subprogram (Pc, Sections, Res, Abbrevs, Unit_Stmt_List);
+
+      if Unit_Stmt_List /= Unsigned_32'Last then
+         Find_Lineno (Pc, Sections, Res, Storage_Offset (Unit_Stmt_List));
+      end if;
+   end Symbolize_Address;
+end Symbolizer;