diff options
Diffstat (limited to 'ortho/mcode')
69 files changed, 22878 insertions, 0 deletions
diff --git a/ortho/mcode/Makefile b/ortho/mcode/Makefile new file mode 100644 index 0000000..cdec5c4 --- /dev/null +++ b/ortho/mcode/Makefile @@ -0,0 +1,32 @@ +ortho_srcdir=.. +GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwlcru + +all: $(ortho_exec) + +$(ortho_exec): memsegs_c.o force + gnatmake -m -o $@ -g -aI$(ortho_srcdir)/mcode -aI$(ortho_srcdir) \ + $(GNAT_FLAGS) ortho_code_main -bargs -E -largs memsegs_c.o #-static + +memsegs_c.o: $(ortho_srcdir)/mcode/memsegs_c.c + $(CC) -c $(CFLAGS) -o $@ $< + +oread: force + gnatmake -m -o $@ -g $(GNAT_FLAGS) -aI../oread ortho_code_main -aI.. + +elfdump: force + gnatmake -m -g $(GNAT_FLAGS) $@ + +coffdump: force + gnatmake -m $(GNAT_FLAGS) $@ + +clean: + $(RM) -f *.o *.ali ortho_code_main elfdump + $(RM) b~*.ad? *~ + +distclean: clean + + +force: + +.PHONY: force all clean + diff --git a/ortho/mcode/binary_file-coff.adb b/ortho/mcode/binary_file-coff.adb new file mode 100644 index 0000000..a49c024 --- /dev/null +++ b/ortho/mcode/binary_file-coff.adb @@ -0,0 +1,407 @@ +-- Binary file COFF writer. +-- 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 Ada.Characters.Latin_1; +with Coff; use Coff; + +package body Binary_File.Coff is + NUL : Character renames Ada.Characters.Latin_1.NUL; + + procedure Write_Coff (Fd : GNAT.OS_Lib.File_Descriptor) + is + use GNAT.OS_Lib; + + procedure Xwrite (Data : System.Address; Len : Natural) is + begin + if Write (Fd, Data, Len) /= Len then + raise Write_Error; + end if; + end Xwrite; + + type Section_Info_Type is record + Sect : Section_Acc; + -- File offset for the data. + Data_Offset : Natural; + -- File offset for the relocs. + Reloc_Offset : Natural; + -- Number of relocs to write. + Nbr_Relocs : Natural; + end record; + type Section_Info_Array is array (Natural range <>) of Section_Info_Type; + Sections : Section_Info_Array (1 .. Nbr_Sections + 3); + Nbr_Sect : Natural; + Sect_Text : constant Natural := 1; + Sect_Data : constant Natural := 2; + Sect_Bss : constant Natural := 3; + Sect : Section_Acc; + + --Section_Align : constant Natural := 2; + + Offset : Natural; + Symtab_Offset : Natural; + -- Number of symtab entries. + Nbr_Symbols : Natural; + Strtab_Offset : Natural; + + function Gen_String (Str : String) return Sym_Name + is + Res : Sym_Name; + begin + if Str'Length <= 8 then + Res.E_Name := (others => NUL); + Res.E_Name (1 .. Str'Length) := Str; + else + Res.E := (E_Zeroes => 0, E_Offset => Unsigned_32 (Offset)); + Offset := Offset + Str'Length + 1; + end if; + return Res; + end Gen_String; + + -- Well known sections name. + type String_Array is array (Sect_Text .. Sect_Bss) of String (1 .. 8); + Sect_Name : constant String_Array := + (Sect_Text => ".text" & NUL & NUL & NUL, + Sect_Data => ".data" & NUL & NUL & NUL, + Sect_Bss => ".bss" & NUL & NUL & NUL & NUL); + type Unsigned32_Array is array (Sect_Text .. Sect_Bss) of Unsigned_32; + Sect_Flags : constant Unsigned32_Array := + (Sect_Text => STYP_TEXT, + Sect_Data => STYP_DATA, + Sect_Bss => STYP_BSS); + + -- If true, do local relocs. + Flag_Reloc : constant Boolean := True; + -- If true, discard local symbols; + Flag_Discard_Local : Boolean := True; + begin + -- If relocations are not performs, then local symbols cannot be + -- discarded. + if not Flag_Reloc then + Flag_Discard_Local := False; + end if; + + -- Fill sections. + Sect := Section_Chain; + Nbr_Sect := 3; + declare + N : Natural; + begin + while Sect /= null loop + if Sect.Name.all = ".text" then + N := Sect_Text; + elsif Sect.Name.all = ".data" then + N := Sect_Data; + elsif Sect.Name.all = ".bss" then + N := Sect_Bss; + else + Nbr_Sect := Nbr_Sect + 1; + N := Nbr_Sect; + end if; + Sections (N).Sect := Sect; + Sect.Number := N; + Sect := Sect.Next; + end loop; + end; + + -- Set data offset. + Offset := Filehdr_Size + Nbr_Sect * Scnhdr_Size; + for I in 1 .. Nbr_Sect loop + if Sections (I).Sect /= null + and then Sections (I).Sect.Data /= null + then + Sections (I).Data_Offset := Offset; + Offset := Offset + Natural (Sections (I).Sect.Pc); + else + Sections (I).Data_Offset := 0; + end if; + end loop; + + -- Set relocs offset. + declare + Rel : Reloc_Acc; + begin + for I in 1 .. Nbr_Sect loop + Sections (I).Nbr_Relocs := 0; + if Sections (I).Sect /= null then + Sections (I).Reloc_Offset := Offset; + if not Flag_Reloc then + -- Do local relocations. + Rel := Sections (I).Sect.First_Reloc; + while Rel /= null loop + if S_Local (Rel.Sym) then + if Get_Section (Rel.Sym) = Sections (I).Sect + then + -- Intra section local reloc. + Apply_Reloc (Sections (I).Sect, Rel); + else + -- Inter section local reloc. + -- A relocation is still required. + Sections (I).Nbr_Relocs := + Sections (I).Nbr_Relocs + 1; + -- FIXME: todo. + raise Program_Error; + end if; + else + Sections (I).Nbr_Relocs := Sections (I).Nbr_Relocs + 1; + end if; + Rel := Rel.Sect_Next; + end loop; + else + Sections (I).Nbr_Relocs := Sections (I).Sect.Nbr_Relocs; + end if; + Offset := Offset + Sections (I).Nbr_Relocs * Relsz; + else + Sections (I).Reloc_Offset := 0; + end if; + end loop; + end; + + Symtab_Offset := Offset; + Nbr_Symbols := 2 + Nbr_Sect * 2; -- 2 for file. + for I in Symbols.First .. Symbols.Last loop + Set_Number (I, Nbr_Symbols); + Nbr_Symbols := Nbr_Symbols + 1; + end loop; + Offset := Offset + Nbr_Symbols * Symesz; + Strtab_Offset := Offset; + Offset := Offset + 4; + + -- Write file header. + declare + Hdr : Filehdr; + begin + Hdr.F_Magic := I386magic; + Hdr.F_Nscns := Unsigned_16 (Nbr_Sect); + Hdr.F_Timdat := 0; + Hdr.F_Symptr := Unsigned_32 (Symtab_Offset); + Hdr.F_Nsyms := Unsigned_32 (Nbr_Symbols); + Hdr.F_Opthdr := 0; + Hdr.F_Flags := F_Lnno; + Xwrite (Hdr'Address, Filehdr_Size); + end; + + -- Write sections header. + for I in 1 .. Nbr_Sect loop + declare + Hdr : Scnhdr; + L : Natural; + begin + case I is + when Sect_Text + | Sect_Data + | Sect_Bss => + Hdr.S_Name := Sect_Name (I); + Hdr.S_Flags := Sect_Flags (I); + when others => + Hdr.S_Flags := 0; + L := Sections (I).Sect.Name'Length; + if L > Hdr.S_Name'Length then + Hdr.S_Name := Sections (I).Sect.Name + (Sections (I).Sect.Name'First .. + Sections (I).Sect.Name'First + Hdr.S_Name'Length - 1); + else + Hdr.S_Name (1 .. L) := Sections (I).Sect.Name.all; + Hdr.S_Name (L + 1 .. Hdr.S_Name'Last) := (others => NUL); + end if; + end case; + Hdr.S_Paddr := 0; + Hdr.S_Vaddr := 0; + Hdr.S_Scnptr := Unsigned_32 (Sections (I).Data_Offset); + Hdr.S_Relptr := Unsigned_32 (Sections (I).Reloc_Offset); + Hdr.S_Lnnoptr := 0; + Hdr.S_Nreloc := Unsigned_16 (Sections (I).Nbr_Relocs); + if Sections (I).Sect /= null then + Hdr.S_Size := Unsigned_32 (Sections (I).Sect.Pc); + else + Hdr.S_Size := 0; + end if; + Hdr.S_Nlnno := 0; + Xwrite (Hdr'Address, Scnhdr_Size); + end; + end loop; + + -- Write sections content. + for I in 1 .. Nbr_Sect loop + if Sections (I).Sect /= null + and then Sections (I).Sect.Data /= null + then + Xwrite (Sections (I).Sect.Data (0)'Address, + Natural (Sections (I).Sect.Pc)); + end if; + end loop; + + -- Write sections reloc. + for I in 1 .. Nbr_Sect loop + if Sections (I).Sect /= null then + declare + R : Reloc_Acc; + Rel : Reloc; + begin + R := Sections (I).Sect.First_Reloc; + while R /= null loop + case R.Kind is + when Reloc_32 => + Rel.R_Type := Reloc_Addr32; + when Reloc_Pc32 => + Rel.R_Type := Reloc_Rel32; + when others => + raise Program_Error; + end case; + Rel.R_Vaddr := Unsigned_32 (R.Addr); + Rel.R_Symndx := Unsigned_32 (Get_Number (R.Sym)); + Xwrite (Rel'Address, Relsz); + R := R.Sect_Next; + end loop; + end; + end if; + end loop; + + -- Write symtab. + -- Write file symbol + aux + declare + Sym : Syment; + A_File : Auxent_File; + begin + Sym := (E => (Inline => True, + E_Name => ".file" & NUL & NUL & NUL), + E_Value => 0, + E_Scnum => N_DEBUG, + E_Type => 0, + E_Sclass => C_FILE, + E_Numaux => 1); + Xwrite (Sym'Address, Symesz); + A_File := (Inline => True, + X_Fname => "testfile.xxxxx"); + Xwrite (A_File'Address, Symesz); + end; + -- Write sections symbol + aux + for I in 1 .. Nbr_Sect loop + declare + A_Scn : Auxent_Scn; + Sym : Syment; + begin + Sym := (E => (Inline => True, E_Name => (others => NUL)), + E_Value => 0, + E_Scnum => Unsigned_16 (I), + E_Type => 0, + E_Sclass => C_STAT, + E_Numaux => 1); + if I <= Sect_Bss then + Sym.E.E_Name := Sect_Name (I); + else + Sym.E := Gen_String (Sections (I).Sect.Name.all); + end if; + Xwrite (Sym'Address, Symesz); + if Sections (I).Sect /= null + and then Sections (I).Sect.Data /= null + then + A_Scn := + (X_Scnlen => Unsigned_32 (Sections (I).Sect.Pc), + X_Nreloc => Unsigned_16 (Sections (I).Nbr_Relocs), + X_Nlinno => 0); + else + A_Scn := (X_Scnlen => 0, X_Nreloc => 0, X_Nlinno => 0); + end if; + Xwrite (A_Scn'Address, Symesz); + end; + end loop; + + -- Write symbols. + declare + procedure Write_Symbol (S : Symbol) + is + Sym : Syment; + begin + Sym := (E => Gen_String (Get_Symbol_Name (S)), + E_Value => Unsigned_32 (Get_Symbol_Value (S)), + E_Scnum => 0, + E_Type => 0, + E_Sclass => C_EXT, + E_Numaux => 0); + case Get_Scope (S) is + when Sym_Local + | Sym_Private => + Sym.E_Sclass := C_STAT; + when Sym_Undef + | Sym_Global => + Sym.E_Sclass := C_EXT; + end case; + if Get_Section (S) /= null then + Sym.E_Scnum := Unsigned_16 (Get_Section (S).Number); + end if; + Xwrite (Sym'Address, Symesz); + end Write_Symbol; + begin + -- First the non-local symbols (1). + for I in Symbols.First .. Symbols.Last loop + if Get_Scope (I) in Symbol_Scope_External then + Write_Symbol (I); + end if; + end loop; + -- Then the local symbols (2). + if not Flag_Discard_Local then + for I in Symbols.First .. Symbols.Last loop + if Get_Scope (I) not in Symbol_Scope_External then + Write_Symbol (I); + end if; + end loop; + end if; + end; + + -- Write strtab. + -- Write strtab length. + declare + L : Unsigned_32; + + procedure Write_String (Str : String) is + begin + if Str (Str'Last) /= NUL then + raise Program_Error; + end if; + if Str'Length <= 9 then + return; + end if; + Xwrite (Str'Address, Str'Length); + Strtab_Offset := Strtab_Offset + Str'Length; + end Write_String; + begin + L := Unsigned_32 (Offset - Strtab_Offset); + Xwrite (L'Address, 4); + + -- Write section name string. + for I in Sect_Bss + 1 .. Nbr_Sect loop + if Sections (I).Sect /= null + and then Sections (I).Sect.Name'Length > 8 + then + Write_String (Sections (I).Sect.Name.all & NUL); + end if; + end loop; + + for I in Symbols.First .. Symbols.Last loop + declare + Str : String := Get_Symbol_Name (I); + begin + Write_String (Str & NUL); + end; + end loop; + if Strtab_Offset + 4 /= Offset then + raise Program_Error; + end if; + end; + end Write_Coff; + +end Binary_File.Coff; diff --git a/ortho/mcode/binary_file-coff.ads b/ortho/mcode/binary_file-coff.ads new file mode 100644 index 0000000..e671555 --- /dev/null +++ b/ortho/mcode/binary_file-coff.ads @@ -0,0 +1,23 @@ +-- Binary file COFF writer. +-- 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.OS_Lib; + +package Binary_File.Coff is + procedure Write_Coff (Fd : GNAT.OS_Lib.File_Descriptor); +end Binary_File.Coff; + diff --git a/ortho/mcode/binary_file-elf.adb b/ortho/mcode/binary_file-elf.adb new file mode 100644 index 0000000..329dbac --- /dev/null +++ b/ortho/mcode/binary_file-elf.adb @@ -0,0 +1,679 @@ +-- Binary file ELF writer. +-- 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 Ada.Text_IO; use Ada.Text_IO; +with Ada.Characters.Latin_1; +with Elf_Common; +with Elf32; + +package body Binary_File.Elf is + NUL : Character renames Ada.Characters.Latin_1.NUL; + + type Arch_Bool is array (Arch_Kind) of Boolean; + Is_Rela : constant Arch_Bool := (Arch_Unknown => False, + Arch_X86 => False, + Arch_Sparc => True, + Arch_Ppc => True); + + procedure Write_Elf (Fd : GNAT.OS_Lib.File_Descriptor) + is + use Elf_Common; + use Elf32; + use GNAT.OS_Lib; + + procedure Xwrite (Data : System.Address; Len : Natural) is + begin + if Write (Fd, Data, Len) /= Len then + raise Write_Error; + end if; + end Xwrite; + + procedure Check_File_Pos (Off : Elf32_Off) + is + L : Long_Integer; + begin + L := File_Length (Fd); + if L /= Long_Integer (Off) then + Put_Line (Standard_Error, "check_file_pos error: expect " + & Elf32_Off'Image (Off) & ", found " + & Long_Integer'Image (L)); + raise Write_Error; + end if; + end Check_File_Pos; + + function Sect_Align (V : Elf32_Off) return Elf32_Off + is + Tmp : Elf32_Off; + begin + Tmp := V + 2 ** 2 - 1; + return Tmp - (Tmp mod 2 ** 2); + end Sect_Align; + + type Section_Info_Type is record + Sect : Section_Acc; + -- Index of the section symbol (in symtab). + Sym : Elf32_Word; + -- Number of relocs to write. + --Nbr_Relocs : Natural; + end record; + type Section_Info_Array is array (Natural range <>) of Section_Info_Type; + Sections : Section_Info_Array (0 .. 3 + 2 * Nbr_Sections); + type Elf32_Shdr_Array is array (Natural range <>) of Elf32_Shdr; + Shdr : Elf32_Shdr_Array (0 .. 3 + 2 * Nbr_Sections); + Nbr_Sect : Natural; + Sect : Section_Acc; + + -- The first 4 sections are always present. + Sect_Null : constant Natural := 0; + Sect_Shstrtab : constant Natural := 1; + Sect_Symtab : constant Natural := 2; + Sect_Strtab : constant Natural := 3; + Sect_First : constant Natural := 4; + + Offset : Elf32_Off; + + -- Size of a relocation entry. + Rel_Size : Natural; + + -- If true, do local relocs. + Flag_Reloc : constant Boolean := True; + -- If true, discard local symbols; + Flag_Discard_Local : Boolean := True; + + -- Number of symbols. + Nbr_Symbols : Natural := 0; + begin + -- If relocations are not performs, then local symbols cannot be + -- discarded. + if not Flag_Reloc then + Flag_Discard_Local := False; + end if; + + -- Set size of a relocation entry. This avoids severals conditionnal. + if Is_Rela (Arch) then + Rel_Size := Elf32_Rela_Size; + else + Rel_Size := Elf32_Rel_Size; + end if; + + -- Set section header. + + -- SHT_NULL. + Shdr (Sect_Null) := + Elf32_Shdr'(Sh_Name => 0, + Sh_Type => SHT_NULL, + Sh_Flags => 0, + Sh_Addr => 0, + Sh_Offset => 0, + Sh_Size => 0, + Sh_Link => 0, + Sh_Info => 0, + Sh_Addralign => 0, + Sh_Entsize => 0); + + -- shstrtab. + Shdr (Sect_Shstrtab) := + Elf32_Shdr'(Sh_Name => 1, + Sh_Type => SHT_STRTAB, + Sh_Flags => 0, + Sh_Addr => 0, + Sh_Offset => 0, -- Filled latter. + -- NUL: 1, .symtab: 8, .strtab: 8 and .shstrtab: 10. + Sh_Size => 1 + 10 + 8 + 8, + Sh_Link => 0, + Sh_Info => 0, + Sh_Addralign => 1, + Sh_Entsize => 0); + + -- Symtab + Shdr (Sect_Symtab) := + Elf32_Shdr'(Sh_Name => 11, + Sh_Type => SHT_SYMTAB, + Sh_Flags => 0, + Sh_Addr => 0, + Sh_Offset => 0, + Sh_Size => 0, + Sh_Link => Elf32_Word (Sect_Strtab), + Sh_Info => 0, -- FIXME + Sh_Addralign => 4, + Sh_Entsize => Elf32_Word (Elf32_Sym_Size)); + + -- strtab. + Shdr (Sect_Strtab) := + Elf32_Shdr'(Sh_Name => 19, + Sh_Type => SHT_STRTAB, + Sh_Flags => 0, + Sh_Addr => 0, + Sh_Offset => 0, + Sh_Size => 0, + Sh_Link => 0, + Sh_Info => 0, + Sh_Addralign => 1, + Sh_Entsize => 0); + + -- Fill sections. + Sect := Section_Chain; + Nbr_Sect := Sect_First; + Nbr_Symbols := 1; + while Sect /= null loop + Sections (Nbr_Sect) := (Sect => Sect, + Sym => Elf32_Word (Nbr_Symbols)); + Nbr_Symbols := Nbr_Symbols + 1; + Sect.Number := Nbr_Sect; + + Shdr (Nbr_Sect) := + Elf32_Shdr'(Sh_Name => Shdr (Sect_Shstrtab).Sh_Size, + Sh_Type => SHT_PROGBITS, + Sh_Flags => 0, + Sh_Addr => Elf32_Addr (Sect.Vaddr), + Sh_Offset => 0, + Sh_Size => 0, + Sh_Link => 0, + Sh_Info => 0, + Sh_Addralign => 2 ** Sect.Align, + Sh_Entsize => Elf32_Word (Sect.Esize)); + if Sect.Data = null then + Shdr (Nbr_Sect).Sh_Type := SHT_NOBITS; + end if; + if (Sect.Flags and Section_Read) /= 0 then + Shdr (Nbr_Sect).Sh_Flags := + Shdr (Nbr_Sect).Sh_Flags or SHF_ALLOC; + end if; + if (Sect.Flags and Section_Exec) /= 0 then + Shdr (Nbr_Sect).Sh_Flags := + Shdr (Nbr_Sect).Sh_Flags or SHF_EXECINSTR; + end if; + if (Sect.Flags and Section_Write) /= 0 then + Shdr (Nbr_Sect).Sh_Flags := + Shdr (Nbr_Sect).Sh_Flags or SHF_WRITE; + end if; + if Sect.Flags = Section_Strtab then + Shdr (Nbr_Sect).Sh_Type := SHT_STRTAB; + Shdr (Nbr_Sect).Sh_Addralign := 1; + Shdr (Nbr_Sect).Sh_Entsize := 0; + end if; + + Shdr (Sect_Shstrtab).Sh_Size := Shdr (Sect_Shstrtab).Sh_Size + + Sect.Name'Length + 1; -- 1 for Nul. + + Nbr_Sect := Nbr_Sect + 1; + if Flag_Reloc then + if Sect.First_Reloc /= null then + Do_Intra_Section_Reloc (Sect); + end if; + end if; + if Sect.First_Reloc /= null then + -- Add a section for the relocs. + Shdr (Nbr_Sect) := Elf32_Shdr' + (Sh_Name => Shdr (Sect_Shstrtab).Sh_Size, + Sh_Type => SHT_NULL, + Sh_Flags => 0, + Sh_Addr => 0, + Sh_Offset => 0, + Sh_Size => 0, + Sh_Link => Elf32_Word (Sect_Symtab), + Sh_Info => Elf32_Word (Nbr_Sect - 1), + Sh_Addralign => 4, + Sh_Entsize => Elf32_Word (Rel_Size)); + + if Is_Rela (Arch) then + Shdr (Nbr_Sect).Sh_Type := SHT_RELA; + else + Shdr (Nbr_Sect).Sh_Type := SHT_REL; + end if; + Shdr (Sect_Shstrtab).Sh_Size := Shdr (Sect_Shstrtab).Sh_Size + + Sect.Name'Length + 4 -- 4 for ".rel" + + Boolean'Pos (Is_Rela (Arch)) + 1; -- 1 for 'a', 1 for Nul. + + Nbr_Sect := Nbr_Sect + 1; + end if; + Sect := Sect.Next; + end loop; + + -- Lay-out sections. + Offset := Elf32_Off (Elf32_Ehdr_Size); + + -- Section table + Offset := Offset + Elf32_Off (Nbr_Sect * Elf32_Shdr_Size); + + -- shstrtab. + Shdr (Sect_Shstrtab).Sh_Offset := Offset; + + Offset := Sect_Align (Offset + Shdr (Sect_Shstrtab).Sh_Size); + + -- user-sections and relocation. + for I in Sect_First .. Nbr_Sect - 1 loop + Sect := Sections (I).Sect; + if Sect /= null then + Sect.Pc := Pow_Align (Sect.Pc, Sect.Align); + Shdr (Sect.Number).Sh_Size := Elf32_Word (Sect.Pc); + if Sect.Data /= null then + -- Set data offset. + Shdr (Sect.Number).Sh_Offset := Offset; + Offset := Offset + Shdr (Sect.Number).Sh_Size; + + -- Set relocs offset. + if Sect.First_Reloc /= null then + Shdr (Sect.Number + 1).Sh_Offset := Offset; + Shdr (Sect.Number + 1).Sh_Size := + Elf32_Word (Sect.Nbr_Relocs * Rel_Size); + Offset := Offset + Shdr (Sect.Number + 1).Sh_Size; + end if; + end if; + -- Set link. + if Sect.Link /= null then + Shdr (Sect.Number).Sh_Link := Elf32_Word (Sect.Link.Number); + end if; + end if; + end loop; + + -- Number symbols, put local before globals. + Nbr_Symbols := 1 + Nbr_Sections; + + -- First local symbols. + for I in Symbols.First .. Symbols.Last loop + case Get_Scope (I) is + when Sym_Private => + Set_Number (I, Nbr_Symbols); + Nbr_Symbols := Nbr_Symbols + 1; + when Sym_Local => + if not Flag_Discard_Local then + Set_Number (I, Nbr_Symbols); + Nbr_Symbols := Nbr_Symbols + 1; + end if; + when Sym_Undef + | Sym_Global => + null; + end case; + end loop; + + Shdr (Sect_Symtab).Sh_Info := Elf32_Word (Nbr_Symbols); + + -- Then globals. + for I in Symbols.First .. Symbols.Last loop + case Get_Scope (I) is + when Sym_Private + | Sym_Local => + null; + when Sym_Undef => + if Get_Used (I) then + Set_Number (I, Nbr_Symbols); + Nbr_Symbols := Nbr_Symbols + 1; + end if; + when Sym_Global => + Set_Number (I, Nbr_Symbols); + Nbr_Symbols := Nbr_Symbols + 1; + end case; + end loop; + + -- Symtab. + Shdr (Sect_Symtab).Sh_Offset := Offset; + -- 1 for nul. + Shdr (Sect_Symtab).Sh_Size := Elf32_Word (Nbr_Symbols * Elf32_Sym_Size); + + Offset := Offset + Shdr (Sect_Symtab).Sh_Size; + + -- Strtab offset. + Shdr (Sect_Strtab).Sh_Offset := Offset; + Shdr (Sect_Strtab).Sh_Size := 1; + + -- Compute length of strtab. + -- First, sections names. + Sect := Section_Chain; +-- while Sect /= null loop +-- Shdr (Sect_Strtab).Sh_Size := +-- Shdr (Sect_Strtab).Sh_Size + Sect.Name'Length + 1; +-- Sect := Sect.Prev; +-- end loop; + -- Then symbols. + declare + Len : Natural; + L : Natural; + begin + Len := 0; + for I in Symbols.First .. Symbols.Last loop + L := Get_Symbol_Name_Length (I) + 1; + case Get_Scope (I) is + when Sym_Local => + if Flag_Discard_Local then + L := 0; + end if; + when Sym_Private => + null; + when Sym_Global => + null; + when Sym_Undef => + if not Get_Used (I) then + L := 0; + end if; + end case; + Len := Len + L; + end loop; + + Shdr (Sect_Strtab).Sh_Size := + Shdr (Sect_Strtab).Sh_Size + Elf32_Word (Len); + end; + + -- Write file header. + declare + Ehdr : Elf32_Ehdr; + begin + Ehdr := (E_Ident => (EI_MAG0 => ELFMAG0, + EI_MAG1 => ELFMAG1, + EI_MAG2 => ELFMAG2, + EI_MAG3 => ELFMAG3, + EI_CLASS => ELFCLASS32, + EI_DATA => ELFDATANONE, + EI_VERSION => EV_CURRENT, + EI_PAD .. 15 => 0), + E_Type => ET_REL, + E_Machine => EM_NONE, + E_Version => Elf32_Word (EV_CURRENT), + E_Entry => 0, + E_Phoff => 0, + E_Shoff => Elf32_Off (Elf32_Ehdr_Size), + E_Flags => 0, + E_Ehsize => Elf32_Half (Elf32_Ehdr_Size), + E_Phentsize => 0, + E_Phnum => 0, + E_Shentsize => Elf32_Half (Elf32_Shdr_Size), + E_Shnum => Elf32_Half (Nbr_Sect), + E_Shstrndx => 1); + case Arch is + when Arch_X86 => + Ehdr.E_Ident (EI_DATA) := ELFDATA2LSB; + Ehdr.E_Machine := EM_386; + when Arch_Sparc => + Ehdr.E_Ident (EI_DATA) := ELFDATA2MSB; + Ehdr.E_Machine := EM_SPARC; + when others => + raise Program_Error; + end case; + Xwrite (Ehdr'Address, Elf32_Ehdr_Size); + end; + + -- Write shdr. + Xwrite (Shdr'Address, Nbr_Sect * Elf32_Shdr_Size); + + -- Write shstrtab + Check_File_Pos (Shdr (Sect_Shstrtab).Sh_Offset); + declare + Str : String := + NUL & ".shstrtab" & NUL & ".symtab" & NUL & ".strtab" & NUL; + Rela : String := NUL & ".rela"; + begin + Xwrite (Str'Address, Str'Length); + Sect := Section_Chain; + while Sect /= null loop + Xwrite (Sect.Name.all'Address, Sect.Name'Length); + if Sect.First_Reloc /= null then + if Is_Rela (Arch) then + Xwrite (Rela'Address, Rela'Length); + else + Xwrite (Rela'Address, Rela'Length - 1); + end if; + Xwrite (Sect.Name.all'Address, Sect.Name'Length); + end if; + Xwrite (NUL'Address, 1); + Sect := Sect.Next; + end loop; + end; + -- Pad. + declare + Delt : Elf32_Word; + Nul_Str : String (1 .. 4) := (others => NUL); + begin + Delt := Shdr (Sect_Shstrtab).Sh_Size and 3; + if Delt /= 0 then + Xwrite (Nul_Str'Address, Natural (4 - Delt)); + end if; + end; + + -- Write sections content and reloc. + for I in 1 .. Nbr_Sect loop + Sect := Sections (I).Sect; + if Sect /= null then + if Sect.Data /= null then + Check_File_Pos (Shdr (Sect.Number).Sh_Offset); + Xwrite (Sect.Data (0)'Address, Natural (Sect.Pc)); + end if; + declare + R : Reloc_Acc; + Rel : Elf32_Rel; + Rela : Elf32_Rela; + S : Elf32_Word; + Nbr_Reloc : Natural; + begin + R := Sect.First_Reloc; + Nbr_Reloc := 0; + while R /= null loop + if R.Done then + S := Sections (Get_Section (R.Sym).Number).Sym; + else + S := Elf32_Word (Get_Number (R.Sym)); + end if; + + if Is_Rela (Arch) then + case R.Kind is + when Reloc_Disp22 => + Rela.R_Info := Elf32_R_Info (S, R_SPARC_WDISP22); + when Reloc_Disp30 => + Rela.R_Info := Elf32_R_Info (S, R_SPARC_WDISP30); + when Reloc_Hi22 => + Rela.R_Info := Elf32_R_Info (S, R_SPARC_HI22); + when Reloc_Lo10 => + Rela.R_Info := Elf32_R_Info (S, R_SPARC_LO10); + when Reloc_32 => + Rela.R_Info := Elf32_R_Info (S, R_SPARC_32); + when Reloc_Ua_32 => + Rela.R_Info := Elf32_R_Info (S, R_SPARC_UA32); + when others => + raise Program_Error; + end case; + Rela.R_Addend := 0; + Rela.R_Offset := Elf32_Addr (R.Addr); + Xwrite (Rela'Address, Elf32_Rela_Size); + else + case R.Kind is + when Reloc_32 => + Rel.R_Info := Elf32_R_Info (S, R_386_32); + when Reloc_Pc32 => + Rel.R_Info := Elf32_R_Info (S, R_386_PC32); + when others => + raise Program_Error; + end case; + Rel.R_Offset := Elf32_Addr (R.Addr); + Xwrite (Rel'Address, Elf32_Rel_Size); + end if; + Nbr_Reloc := Nbr_Reloc + 1; + R := R.Sect_Next; + end loop; + if Nbr_Reloc /= Sect.Nbr_Relocs then + raise Program_Error; + end if; + end; + end if; + end loop; + + -- Write symbol table. + Check_File_Pos (Shdr (Sect_Symtab).Sh_Offset); + declare + Str_Off : Elf32_Word; + + procedure Gen_Sym (S : Symbol) + is + Sym : Elf32_Sym; + Bind : Elf32_Uchar; + Typ : Elf32_Uchar; + begin + Sym := Elf32_Sym'(St_Name => Str_Off, + St_Value => Elf32_Addr (Get_Symbol_Value (S)), + St_Size => 0, + St_Info => 0, + St_Other => 0, + St_Shndx => SHN_UNDEF); + if Get_Section (S) /= null then + Sym.St_Shndx := Elf32_Half (Get_Section (S).Number); + end if; + case Get_Scope (S) is + when Sym_Private + | Sym_Local => + Bind := STB_LOCAL; + Typ := STT_NOTYPE; + when Sym_Global => + Bind := STB_GLOBAL; + if Get_Section (S) /= null + and then (Get_Section (S).Flags and Section_Exec) /= 0 + then + Typ := STT_FUNC; + else + Typ := STT_OBJECT; + end if; + when Sym_Undef => + Bind := STB_GLOBAL; + Typ := STT_NOTYPE; + end case; + Sym.St_Info := Elf32_St_Info (Bind, Typ); + + Xwrite (Sym'Address, Elf32_Sym_Size); + + Str_Off := Str_Off + Elf32_Off (Get_Symbol_Name_Length (S) + 1); + end Gen_Sym; + + Sym : Elf32_Sym; + begin + + Str_Off := 1; + + -- write null entry + Sym := Elf32_Sym'(St_Name => 0, + St_Value => 0, + St_Size => 0, + St_Info => 0, + St_Other => 0, + St_Shndx => SHN_UNDEF); + Xwrite (Sym'Address, Elf32_Sym_Size); + + -- write section entries + Sect := Section_Chain; + while Sect /= null loop +-- Sym := Elf32_Sym'(St_Name => Str_Off, +-- St_Value => 0, +-- St_Size => 0, +-- St_Info => Elf32_St_Info (STB_LOCAL, +-- STT_NOTYPE), +-- St_Other => 0, +-- St_Shndx => Elf32_Half (Sect.Number)); +-- Xwrite (Sym'Address, Elf32_Sym_Size); +-- Str_Off := Str_Off + Sect.Name'Length + 1; + + Sym := Elf32_Sym'(St_Name => 0, + St_Value => 0, + St_Size => 0, + St_Info => Elf32_St_Info (STB_LOCAL, + STT_SECTION), + St_Other => 0, + St_Shndx => Elf32_Half (Sect.Number)); + Xwrite (Sym'Address, Elf32_Sym_Size); + Sect := Sect.Next; + end loop; + + -- First local symbols. + for I in Symbols.First .. Symbols.Last loop + case Get_Scope (I) is + when Sym_Private => + Gen_Sym (I); + when Sym_Local => + if not Flag_Discard_Local then + Gen_Sym (I); + end if; + when Sym_Global + | Sym_Undef => + null; + end case; + end loop; + + -- Then global symbols. + for I in Symbols.First .. Symbols.Last loop + case Get_Scope (I) is + when Sym_Global => + Gen_Sym (I); + when Sym_Undef => + if Get_Used (I) then + Gen_Sym (I); + end if; + when Sym_Private + | Sym_Local => + null; + end case; + end loop; + end; + + -- Write strtab. + Check_File_Pos (Shdr (Sect_Strtab).Sh_Offset); + -- First is NUL. + Xwrite (NUL'Address, 1); + -- Then the sections name. +-- Sect := Section_List; +-- while Sect /= null loop +-- Xwrite (Sect.Name.all'Address, Sect.Name'Length); +-- Xwrite (NUL'Address, 1); +-- Sect := Sect.Prev; +-- end loop; + + -- Then the symbols name. + declare + procedure Write_Sym_Name (S : Symbol) + is + Str : String := Get_Symbol_Name (S) & NUL; + begin + Xwrite (Str'Address, Str'Length); + end Write_Sym_Name; + begin + -- First locals. + for I in Symbols.First .. Symbols.Last loop + case Get_Scope (I) is + when Sym_Private => + Write_Sym_Name (I); + when Sym_Local => + if not Flag_Discard_Local then + Write_Sym_Name (I); + end if; + when Sym_Global + | Sym_Undef => + null; + end case; + end loop; + + -- Then global symbols. + for I in Symbols.First .. Symbols.Last loop + case Get_Scope (I) is + when Sym_Global => + Write_Sym_Name (I); + when Sym_Undef => + if Get_Used (I) then + Write_Sym_Name (I); + end if; + when Sym_Private + | Sym_Local => + null; + end case; + end loop; + end; + end Write_Elf; + +end Binary_File.Elf; diff --git a/ortho/mcode/binary_file-elf.ads b/ortho/mcode/binary_file-elf.ads new file mode 100644 index 0000000..e0d3a4d --- /dev/null +++ b/ortho/mcode/binary_file-elf.ads @@ -0,0 +1,22 @@ +-- Binary file ELF writer. +-- 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.OS_Lib; + +package Binary_File.Elf is + procedure Write_Elf (Fd : GNAT.OS_Lib.File_Descriptor); +end Binary_File.Elf; diff --git a/ortho/mcode/binary_file-memory.adb b/ortho/mcode/binary_file-memory.adb new file mode 100644 index 0000000..c094e05 --- /dev/null +++ b/ortho/mcode/binary_file-memory.adb @@ -0,0 +1,102 @@ +-- Binary file execute in memory handler. +-- 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 Ada.Text_IO; use Ada.Text_IO; +with Ada.Unchecked_Conversion; + +package body Binary_File.Memory is + -- Absolute section. + Sect_Abs : Section_Acc; + + procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address) + is + function Conv is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Pc_Type); + begin + Set_Symbol_Value (Sym, Conv (Addr)); + Set_Scope (Sym, Sym_Global); + Set_Section (Sym, Sect_Abs); + end Set_Symbol_Address; + + procedure Write_Memory_Init + is + use SSE; + Sect : Section_Acc; + begin + -- Relocate section in memory. + Sect := Section_Chain; + while Sect /= null loop + if Sect.Data = null then + if Sect.Pc > 0 then + Resize (Sect, Sect.Pc); + Sect.Data (0 .. Sect.Pc - 1) := (others => 0); + else + null; + --Sect.Data := new Byte_Array (1 .. 0); + end if; + end if; + if Sect.Data_Max > 0 then + Sect.Vaddr := To_Integer (Sect.Data (0)'Address); + end if; + Sect := Sect.Next; + end loop; + + Create_Section (Sect_Abs, "*ABS*", Section_Exec); + Sect_Abs.Vaddr := 0; + end Write_Memory_Init; + + procedure Write_Memory_Relocate (Error : out Boolean) + is + use SSE; + Sect : Section_Acc; + Rel : Reloc_Acc; + N_Rel : Reloc_Acc; + begin + -- Do all relocations. + Sect := Section_Chain; + Error := False; + while Sect /= null loop +-- Put_Line ("Section: " & Sect.Name.all & ", Flags:" +-- & Section_Flags'Image (Sect.Flags)); + Rel := Sect.First_Reloc; + while Rel /= null loop + N_Rel := Rel.Sect_Next; + if Get_Scope (Rel.Sym) = Sym_Undef then + Put_Line ("symbol " & Get_Symbol_Name (Rel.Sym) + & " is undefined"); + Error := True; + else + Apply_Reloc (Sect, Rel); + end if; + Free (Rel); + Rel := N_Rel; + end loop; + + Sect.First_Reloc := null; + Sect.Last_Reloc := null; + Sect.Nbr_Relocs := 0; + + if (Sect.Flags and Section_Exec) /= 0 + and (Sect.Flags and Section_Write) = 0 + then + Memsegs.Set_Rx (Sect.Seg); + end if; + + Sect := Sect.Next; + end loop; + end Write_Memory_Relocate; +end Binary_File.Memory; diff --git a/ortho/mcode/binary_file-memory.ads b/ortho/mcode/binary_file-memory.ads new file mode 100644 index 0000000..5238fa0 --- /dev/null +++ b/ortho/mcode/binary_file-memory.ads @@ -0,0 +1,22 @@ +-- Binary file execute in memory handler. +-- 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. +package Binary_File.Memory is + procedure Write_Memory_Init; + procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address); + procedure Write_Memory_Relocate (Error : out Boolean); +end Binary_File.Memory; diff --git a/ortho/mcode/binary_file.adb b/ortho/mcode/binary_file.adb new file mode 100644 index 0000000..58c5a79 --- /dev/null +++ b/ortho/mcode/binary_file.adb @@ -0,0 +1,985 @@ +-- Binary file handling. +-- 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 System; +with System.Storage_Elements; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Characters.Latin_1; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with GNAT.Table; +with Hex_Images; use Hex_Images; +with Disassemble; + +package body Binary_File is + Cur_Sect : Section_Acc := null; + + HT : Character renames Ada.Characters.Latin_1.HT; + + function To_Byte_Array_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Byte_Array_Acc); + + -- Resize a section to SIZE bytes. + procedure Resize (Sect : Section_Acc; Size : Pc_Type) + is + begin + Sect.Data_Max := Size; + Memsegs.Resize (Sect.Seg, Natural (Size)); + Sect.Data := To_Byte_Array_Acc (Memsegs.Get_Address (Sect.Seg)); + end Resize; + + function Get_Scope (Sym : Symbol) return Symbol_Scope is + begin + return Symbols.Table (Sym).Scope; + end Get_Scope; + + procedure Set_Scope (Sym : Symbol; Scope : Symbol_Scope) is + begin + Symbols.Table (Sym).Scope := Scope; + end Set_Scope; + + function Get_Section (Sym : Symbol) return Section_Acc is + begin + return Symbols.Table (Sym).Section; + end Get_Section; + + procedure Set_Section (Sym : Symbol; Sect : Section_Acc) is + begin + Symbols.Table (Sym).Section := Sect; + end Set_Section; + + function Get_Number (Sym : Symbol) return Natural is + begin + return Symbols.Table (Sym).Number; + end Get_Number; + + procedure Set_Number (Sym : Symbol; Num : Natural) is + begin + Symbols.Table (Sym).Number := Num; + end Set_Number; + + function Get_Relocs (Sym : Symbol) return Reloc_Acc is + begin + return Symbols.Table (Sym).Relocs; + end Get_Relocs; + + procedure Set_Relocs (Sym : Symbol; Reloc : Reloc_Acc) is + begin + Symbols.Table (Sym).Relocs := Reloc; + end Set_Relocs; + + function Get_Name (Sym : Symbol) return O_Ident is + begin + return Symbols.Table (Sym).Name; + end Get_Name; + + function Get_Used (Sym : Symbol) return Boolean is + begin + return Symbols.Table (Sym).Used; + end Get_Used; + + procedure Set_Used (Sym : Symbol; Val : Boolean) is + begin + Symbols.Table (Sym).Used := Val; + end Set_Used; + + function Get_Symbol_Value (Sym : Symbol) return Pc_Type is + begin + return Symbols.Table (Sym).Value; + end Get_Symbol_Value; + + procedure Set_Symbol_Value (Sym : Symbol; Val : Pc_Type) is + begin + Symbols.Table (Sym).Value := Val; + end Set_Symbol_Value; + + function S_Defined (Sym : Symbol) return Boolean is + begin + return Get_Scope (Sym) /= Sym_Undef; + end S_Defined; + + function S_Local (Sym : Symbol) return Boolean is + begin + return Get_Scope (Sym) = Sym_Local; + end S_Local; + + procedure Create_Section (Sect : out Section_Acc; + Name : String; Flags : Section_Flags) + is + begin + Sect := new Section_Type'(Next => null, + Flags => Flags, + Name => new String'(Name), + Link => null, + Align => 2, + Esize => 0, + Pc => 0, + Insn_Pc => 0, + Data => null, + Data_Max => 0, + First_Reloc => null, + Last_Reloc => null, + Nbr_Relocs => 0, + Number => 0, + Seg => Memsegs.Create, + Vaddr => 0); + if (Flags and Section_Zero) = 0 then + -- Allocate memory for the segment, unless BSS. + Resize (Sect, 8192); + end if; + if (Flags and Section_Strtab) /= 0 then + Sect.Align := 0; + end if; + if Section_Chain = null then + Section_Chain := Sect; + else + Section_Last.Next := Sect; + end if; + Section_Last := Sect; + Nbr_Sections := Nbr_Sections + 1; + end Create_Section; + + procedure Sect_Prealloc (Sect : Section_Acc; L : Pc_Type) + is + New_Max : Pc_Type; + begin + if Sect.Pc + L < Sect.Data_Max then + return; + end if; + New_Max := Sect.Data_Max; + loop + New_Max := New_Max * 2; + exit when Sect.Pc + L < New_Max; + end loop; + Resize (Sect, New_Max); + end Sect_Prealloc; + + procedure Merge_Section (Dest : Section_Acc; Src : in out Section_Acc) + is + Rel : Reloc_Acc; + begin + -- Sanity checks. + if Src = null or else Dest = Src then + raise Program_Error; + end if; + + Rel := Src.First_Reloc; + + if Rel /= null then + -- Move relocs. + if Dest.Last_Reloc = null then + Dest.First_Reloc := Rel; + Dest.Last_Reloc := Rel; + else + Dest.Last_Reloc.Sect_Next := Rel; + Dest.Last_Reloc := Rel; + end if; + Dest.Nbr_Relocs := Dest.Nbr_Relocs + Src.Nbr_Relocs; + + + -- Reloc reloc, since the pc has changed. + while Rel /= null loop + Rel.Addr := Rel.Addr + Dest.Pc; + Rel := Rel.Sect_Next; + end loop; + end if; + + if Src.Pc > 0 then + Sect_Prealloc (Dest, Src.Pc); + Dest.Data (Dest.Pc .. Dest.Pc + Src.Pc - 1) := + Src.Data (0 .. Src.Pc - 1); + Dest.Pc := Dest.Pc + Src.Pc; + end if; + + Memsegs.Delete (Src.Seg); + Src.Pc := 0; + Src.Data_Max := 0; + Src.Data := null; + Src.First_Reloc := null; + Src.Last_Reloc := null; + Src.Nbr_Relocs := 0; + + -- Remove from section_chain. + if Section_Chain = Src then + Section_Chain := Src.Next; + else + declare + Sect : Section_Acc; + begin + Sect := Section_Chain; + while Sect.Next /= Src loop + Sect := Sect.Next; + end loop; + Sect.Next := Src.Next; + if Section_Last = Src then + Section_Last := Sect; + end if; + end; + end if; + Nbr_Sections := Nbr_Sections - 1; + end Merge_Section; + + procedure Set_Section_Info (Sect : Section_Acc; + Link : Section_Acc; + Align : Natural; + Esize : Natural) + is + begin + Sect.Link := Link; + Sect.Align := Align; + Sect.Esize := Esize; + end Set_Section_Info; + + procedure Set_Current_Section (Sect : Section_Acc) is + begin + -- If the current section does not change, this is a no-op. + if Cur_Sect = Sect then + return; + end if; + + if Dump_Asm then + Put_Line (HT & ".section """ & Sect.Name.all & """"); + end if; + Cur_Sect := Sect; + end Set_Current_Section; + + function Get_Current_Pc return Pc_Type is + begin + return Cur_Sect.Pc; + end Get_Current_Pc; + + function Get_Pc (Sect : Section_Acc) return Pc_Type is + begin + return Sect.Pc; + end Get_Pc; + + + procedure Prealloc (L : Pc_Type) is + begin + Sect_Prealloc (Cur_Sect, L); + end Prealloc; + + procedure Start_Insn is + begin + -- Check there is enough memory for the next instruction. + Sect_Prealloc (Cur_Sect, 16); + if Cur_Sect.Insn_Pc /= 0 then + -- end_insn was not called. + raise Program_Error; + end if; + Cur_Sect.Insn_Pc := Cur_Sect.Pc; + end Start_Insn; + + procedure Get_Symbol_At_Addr (Addr : System.Address; + Line : in out String; + Line_Len : in out Natural) + is + use System; + use System.Storage_Elements; + Off : Pc_Type; + Reloc : Reloc_Acc; + begin + -- Check if addr is in the current section. + if Addr < Cur_Sect.Data (0)'Address + or else Addr > Cur_Sect.Data (Cur_Sect.Pc)'Address + then + raise Program_Error; + --return; + end if; + Off := Pc_Type + (To_Integer (Addr) - To_Integer (Cur_Sect.Data (0)'Address)); + + -- Find a relocation at OFF. + Reloc := Cur_Sect.First_Reloc; + while Reloc /= null loop + if Reloc.Addr = Off then + declare + Str : String := Get_Symbol_Name (Reloc.Sym); + begin + Line (Line'First .. Line'First + Str'Length - 1) := Str; + Line_Len := Line_Len + Str'Length; + return; + end; + end if; + Reloc := Reloc.Sect_Next; + end loop; + end Get_Symbol_At_Addr; + + procedure End_Insn + is + Str : String (1 .. 128); + Len : Natural; + Insn_Len : Natural; + begin + --if Insn_Pc = 0 then + -- -- start_insn was not called. + -- raise Program_Error; + --end if; + if Debug_Hex then + Put (HT); + Put ('#'); + for I in Cur_Sect.Insn_Pc .. Cur_Sect.Pc - 1 loop + Put (' '); + Put (Hex_Image (Unsigned_8 (Cur_Sect.Data (I)))); + end loop; + New_Line; + end if; + + if Dump_Asm then + Disassemble.Disassemble_Insn + (Cur_Sect.Data (Cur_Sect.Insn_Pc)'Address, + Unsigned_32 (Cur_Sect.Insn_Pc), + Str, Len, Insn_Len, + Get_Symbol_At_Addr'Access); + Put (HT); + Put_Line (Str (1 .. Len)); + end if; + --if Natural (Cur_Pc - Insn_Pc) /= Insn_Len then + -- raise Program_Error; + --end if; + Cur_Sect.Insn_Pc := 0; + end End_Insn; + + procedure Gen_B8 (B : Byte) is + begin + Cur_Sect.Data (Cur_Sect.Pc) := B; + Cur_Sect.Pc := Cur_Sect.Pc + 1; + end Gen_B8; + + procedure Gen_B16 (B0, B1 : Byte) is + begin + Cur_Sect.Data (Cur_Sect.Pc + 0) := B0; + Cur_Sect.Data (Cur_Sect.Pc + 1) := B1; + Cur_Sect.Pc := Cur_Sect.Pc + 2; + end Gen_B16; + + procedure Gen_Le8 (B : Unsigned_32) is + begin + Cur_Sect.Data (Cur_Sect.Pc) := Byte (B and 16#Ff#); + Cur_Sect.Pc := Cur_Sect.Pc + 1; + end Gen_Le8; + + procedure Gen_Le16 (B : Unsigned_32) is + begin + Cur_Sect.Data (Cur_Sect.Pc + 0) := Byte (Shift_Right (B, 0) and 16#Ff#); + Cur_Sect.Data (Cur_Sect.Pc + 1) := Byte (Shift_Right (B, 8) and 16#Ff#); + Cur_Sect.Pc := Cur_Sect.Pc + 2; + end Gen_Le16; + + procedure Gen_Be16 (B : Unsigned_32) is + begin + Cur_Sect.Data (Cur_Sect.Pc + 0) := Byte (Shift_Right (B, 8) and 16#Ff#); + Cur_Sect.Data (Cur_Sect.Pc + 1) := Byte (Shift_Right (B, 0) and 16#Ff#); + Cur_Sect.Pc := Cur_Sect.Pc + 2; + end Gen_Be16; + + procedure Write_B8 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_8) is + begin + Sect.Data (Pc) := Byte (V); + end Write_B8; + + procedure Write_Be16 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is + begin + Sect.Data (Pc + 0) := Byte (Shift_Right (V, 8) and 16#Ff#); + Sect.Data (Pc + 1) := Byte (Shift_Right (V, 0) and 16#Ff#); + end Write_Be16; + + procedure Write_Le32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is + begin + Sect.Data (Pc + 0) := Byte (Shift_Right (V, 0) and 16#Ff#); + Sect.Data (Pc + 1) := Byte (Shift_Right (V, 8) and 16#Ff#); + Sect.Data (Pc + 2) := Byte (Shift_Right (V, 16) and 16#Ff#); + Sect.Data (Pc + 3) := Byte (Shift_Right (V, 24) and 16#Ff#); + end Write_Le32; + + procedure Write_Be32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is + begin + Sect.Data (Pc + 0) := Byte (Shift_Right (V, 24) and 16#Ff#); + Sect.Data (Pc + 1) := Byte (Shift_Right (V, 16) and 16#Ff#); + Sect.Data (Pc + 2) := Byte (Shift_Right (V, 8) and 16#Ff#); + Sect.Data (Pc + 3) := Byte (Shift_Right (V, 0) and 16#Ff#); + end Write_Be32; + + procedure Write_16 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32) + is + subtype B2 is Byte_Array_Base (0 .. 1); + function To_B2 is new Ada.Unchecked_Conversion + (Source => Unsigned_16, Target => B2); + begin + Sect.Data (Pc + 0 .. Pc + 1) := To_B2 (Unsigned_16 (B)); + end Write_16; + + procedure Write_32 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32) + is + subtype B4 is Byte_Array_Base (0 .. 3); + function To_B4 is new Ada.Unchecked_Conversion + (Source => Unsigned_32, Target => B4); + begin + Sect.Data (Pc + 0 .. Pc + 3) := To_B4 (B); + end Write_32; + + procedure Gen_16 (B : Unsigned_32) is + begin + Write_16 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 2; + end Gen_16; + + procedure Gen_32 (B : Unsigned_32) is + begin + Write_32 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 4; + end Gen_32; + + function Read_Le32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 is + begin + return Shift_Left (Unsigned_32 (Sect.Data (Pc + 0)), 0) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 1)), 8) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 2)), 16) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 3)), 24); + end Read_Le32; + + function Read_Be32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 is + begin + return Shift_Left (Unsigned_32 (Sect.Data (Pc + 0)), 24) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 1)), 16) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 2)), 8) + or Shift_Left (Unsigned_32 (Sect.Data (Pc + 3)), 0); + end Read_Be32; + + procedure Add_Le32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is + begin + Write_Le32 (Sect, Pc, V + Read_Le32 (Sect, Pc)); + end Add_Le32; + + procedure Patch_Le32 (Pc : Pc_Type; V : Unsigned_32) is + begin + if Pc + 4 > Get_Current_Pc then + raise Program_Error; + end if; + Write_Le32 (Cur_Sect, Pc, V); + end Patch_Le32; + + procedure Patch_Be32 (Pc : Pc_Type; V : Unsigned_32) is + begin + if Pc + 4 > Get_Current_Pc then + raise Program_Error; + end if; + Write_Be32 (Cur_Sect, Pc, V); + end Patch_Be32; + + procedure Patch_Be16 (Pc : Pc_Type; V : Unsigned_32) is + begin + if Pc + 2 > Get_Current_Pc then + raise Program_Error; + end if; + Write_Be16 (Cur_Sect, Pc, V); + end Patch_Be16; + + procedure Patch_B8 (Pc : Pc_Type; V : Unsigned_8) is + begin + if Pc >= Get_Current_Pc then + raise Program_Error; + end if; + Write_B8 (Cur_Sect, Pc, V); + end Patch_B8; + + procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32) is + begin + if Pc + 4 > Get_Current_Pc then + raise Program_Error; + end if; + Write_32 (Cur_Sect, Pc, V); + end Patch_32; + + procedure Gen_Le32 (B : Unsigned_32) is + begin + Write_Le32 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 4; + end Gen_Le32; + + procedure Gen_Be32 (B : Unsigned_32) is + begin + Write_Be32 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 4; + end Gen_Be32; + + procedure Gen_Data_Le8 (B : Unsigned_32) is + begin + if Dump_Asm then + Put_Line (HT & ".byte 0x" & Hex_Image (Unsigned_8 (B))); + end if; + Gen_Le8 (B); + end Gen_Data_Le8; + + procedure Gen_Data_Le16 (B : Unsigned_32) is + begin + if Dump_Asm then + Put_Line (HT & ".half 0x" & Hex_Image (Unsigned_16 (B))); + end if; + Gen_Le16 (B); + end Gen_Data_Le16; + + procedure Gen_Data_32 (Sym : Symbol; Offset : Integer_32) is + begin + if Dump_Asm then + if Sym = Null_Symbol then + Put_Line (HT & ".word 0x" & Hex_Image (Offset)); + else + if Offset = 0 then + Put_Line (HT & ".word " & Get_Symbol_Name (Sym)); + else + Put_Line (HT & ".word " & Get_Symbol_Name (Sym) & " + " + & Hex_Image (Offset)); + end if; + end if; + end if; + case Arch is + when Arch_X86 => + Gen_X86_32 (Sym, Offset); + when Arch_Sparc => + Gen_Sparc_32 (Sym, Offset); + when others => + raise Program_Error; + end case; + end Gen_Data_32; + + function Create_Symbol (Name : O_Ident) return Symbol + is + begin + Symbols.Append (Symbol_Type'(Section => null, + Value => 0, + Scope => Sym_Undef, + Used => False, + Name => Name, + Relocs => null, + Number => 0)); + return Symbols.Last; + end Create_Symbol; + + Last_Label : Natural := 1; + + function Create_Local_Symbol return Symbol is + begin + Symbols.Append (Symbol_Type'(Section => Cur_Sect, + Value => 0, + Scope => Sym_Local, + Used => False, + Name => O_Ident_Nul, + Relocs => null, + Number => Last_Label)); + + Last_Label := Last_Label + 1; + + return Symbols.Last; + end Create_Local_Symbol; + + function Get_Symbol_Name (Sym : Symbol) return String + is + Res : String (1 .. 10); + N : Natural; + P : Natural; + begin + if S_Local (Sym) then + N := Get_Number (Sym); + P := Res'Last; + loop + Res (P) := Character'Val ((N mod 10) + Character'Pos ('0')); + N := N / 10; + P := P - 1; + exit when N = 0; + end loop; + Res (P) := 'L'; + Res (P - 1) := '.'; + return Res (P - 1 .. Res'Last); + else + if Is_Nul (Get_Name (Sym)) then + return "ANON"; + else + return Get_String (Get_Name (Sym)); + end if; + end if; + end Get_Symbol_Name; + + function Get_Symbol_Name_Length (Sym : Symbol) return Natural + is + N : Natural; + begin + if S_Local (Sym) then + N := 10; + for I in 3 .. 8 loop + if Get_Number (Sym) < N then + return I; + end if; + N := N * 10; + end loop; + raise Program_Error; + else + return Get_String_Length (Get_Name (Sym)); + end if; + end Get_Symbol_Name_Length; + + function Get_Symbol (Name : String) return Symbol is + begin + for I in Symbols.First .. Symbols.Last loop + if Get_Symbol_Name (I) = Name then + return I; + end if; + end loop; + return Null_Symbol; + end Get_Symbol; + + function Pow_Align (V : Pc_Type; Align : Natural) return Pc_Type + is + Tmp : Pc_Type; + begin + Tmp := V + 2 ** Align - 1; + return Tmp - (Tmp mod Pc_Type (2 ** Align)); + end Pow_Align; + + procedure Gen_Pow_Align (Align : Natural) is + begin + if Align = 0 then + return; + end if; + if Dump_Asm then + Put_Line (HT & ".align" & Natural'Image (Align)); + end if; + Cur_Sect.Pc := Pow_Align (Cur_Sect.Pc, Align); + end Gen_Pow_Align; + + -- Generate LENGTH bytes set to 0. + procedure Gen_Space (Length : Integer_32) is + begin + if Dump_Asm then + Put_Line (HT & ".space" & Integer_32'Image (Length)); + end if; + Cur_Sect.Pc := Cur_Sect.Pc + Pc_Type (Length); + end Gen_Space; + + procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean) + is + use Ada.Text_IO; + begin + case Get_Scope (Sym) is + when Sym_Local => + if Export then + raise Program_Error; + end if; + when Sym_Private + | Sym_Global => + raise Program_Error; + when Sym_Undef => + if Export then + Set_Scope (Sym, Sym_Global); + else + Set_Scope (Sym, Sym_Private); + end if; + end case; + -- Set value/section. + Set_Symbol_Value (Sym, Cur_Sect.Pc); + Set_Section (Sym, Cur_Sect); + + if Dump_Asm then + if Export then + Put_Line (HT & ".globl " & Get_Symbol_Name (Sym)); + end if; + Put (Get_Symbol_Name (Sym)); + Put_Line (":"); + end if; + end Set_Symbol_Pc; + + procedure Add_Reloc (Sym : Symbol; Kind : Reloc_Kind) + is + Reloc : Reloc_Acc; + begin + Reloc := new Reloc_Type'(Kind => Kind, + Done => False, + Sym_Next => Get_Relocs (Sym), + Sect_Next => null, + Addr => Cur_Sect.Pc, + Sym => Sym); + Set_Relocs (Sym, Reloc); + if Cur_Sect.First_Reloc = null then + Cur_Sect.First_Reloc := Reloc; + else + Cur_Sect.Last_Reloc.Sect_Next := Reloc; + end if; + Cur_Sect.Last_Reloc := Reloc; + Cur_Sect.Nbr_Relocs := Cur_Sect.Nbr_Relocs + 1; + end Add_Reloc; + + procedure Gen_X86_Pc32 (Sym : Symbol) + is + begin + Add_Reloc (Sym, Reloc_Pc32); + Gen_Le32 (16#ff_ff_ff_fc#); + end Gen_X86_Pc32; + + procedure Gen_Sparc_Disp22 (W : Unsigned_32; Sym : Symbol) + is + begin + Add_Reloc (Sym, Reloc_Disp22); + Gen_Be32 (W); + end Gen_Sparc_Disp22; + + procedure Gen_Sparc_Disp30 (W : Unsigned_32; Sym : Symbol) + is + begin + Add_Reloc (Sym, Reloc_Disp30); + Gen_Be32 (W); + end Gen_Sparc_Disp30; + + procedure Gen_Sparc_Hi22 (W : Unsigned_32; + Sym : Symbol; Off : Unsigned_32) + is + pragma Unreferenced (Off); + begin + Add_Reloc (Sym, Reloc_Hi22); + Gen_Be32 (W); + end Gen_Sparc_Hi22; + + procedure Gen_Sparc_Lo10 (W : Unsigned_32; + Sym : Symbol; Off : Unsigned_32) + is + pragma Unreferenced (Off); + begin + Add_Reloc (Sym, Reloc_Lo10); + Gen_Be32 (W); + end Gen_Sparc_Lo10; + + function Conv is new Ada.Unchecked_Conversion + (Source => Integer_32, Target => Unsigned_32); + + procedure Gen_X86_32 (Sym : Symbol; Offset : Integer_32) is + begin + if Sym /= Null_Symbol then + Add_Reloc (Sym, Reloc_32); + end if; + Gen_Le32 (Conv (Offset)); + end Gen_X86_32; + + procedure Gen_Sparc_32 (Sym : Symbol; Offset : Integer_32) is + begin + if Sym /= Null_Symbol then + Add_Reloc (Sym, Reloc_32); + end if; + Gen_Be32 (Conv (Offset)); + end Gen_Sparc_32; + + procedure Gen_Sparc_Ua_32 (Sym : Symbol; Offset : Integer_32) + is + pragma Unreferenced (Offset); + begin + if Sym /= Null_Symbol then + Add_Reloc (Sym, Reloc_Ua_32); + end if; + Gen_Be32 (0); + end Gen_Sparc_Ua_32; + + procedure Gen_Ua_32 (Sym : Symbol; Offset : Integer_32) is + begin + case Arch is + when Arch_X86 => + Gen_X86_32 (Sym, Offset); + when Arch_Sparc => + Gen_Sparc_Ua_32 (Sym, Offset); + when others => + raise Program_Error; + end case; + end Gen_Ua_32; + + procedure Gen_Ppc_24 (V : Unsigned_32; Sym : Symbol) + is + begin + Add_Reloc (Sym, Reloc_Ppc_Addr24); + Gen_32 (V); + end Gen_Ppc_24; + + function Get_Symbol_Vaddr (Sym : Symbol) return Unsigned_32 is + begin + return Unsigned_32 (Get_Section (Sym).Vaddr) + + Unsigned_32 (Get_Symbol_Value (Sym)); + end Get_Symbol_Vaddr; + + procedure Write_Left_Be32 (Sect : Section_Acc; + Addr : Pc_Type; + Size : Natural; + Val : Unsigned_32) + is + W : Unsigned_32; + Mask : Unsigned_32; + begin + -- Write value. + Mask := Shift_Left (1, Size) - 1; + W := Read_Be32 (Sect, Addr); + Write_Be32 (Sect, Addr, (W and not Mask) or (Val and Mask)); + end Write_Left_Be32; + + procedure Set_Wdisp (Sect : Section_Acc; + Addr : Pc_Type; + Sym : Symbol; + Size : Natural) + is + D : Unsigned_32; + Mask : Unsigned_32; + begin + D := Get_Symbol_Vaddr (Sym) - + (Unsigned_32 (Sect.Vaddr) + Unsigned_32 (Addr)); + -- Check overflow. + Mask := Shift_Left (1, Size + 2) - 1; + if (D and Shift_Left (1, Size + 1)) = 0 then + if (D and not Mask) /= 0 then + raise Program_Error; + end if; + else + if (D and not Mask) /= not Mask then + raise Program_Error; + end if; + end if; + -- Write value. + Write_Left_Be32 (Sect, Addr, Size, D / 4); + end Set_Wdisp; + + procedure Do_Reloc (Kind : Reloc_Kind; + Sect : Section_Acc; Addr : Pc_Type; Sym : Symbol) + is + begin + if Get_Scope (Sym) = Sym_Undef then + raise Program_Error; + end if; + + case Kind is + when Reloc_32 => + Add_Le32 (Sect, Addr, Get_Symbol_Vaddr (Sym)); + + when Reloc_Pc32 => + Add_Le32 (Sect, Addr, + Get_Symbol_Vaddr (Sym) - + (Unsigned_32 (Sect.Vaddr) + Unsigned_32 (Addr))); + + when Reloc_Disp22 => + Set_Wdisp (Sect, Addr, Sym, 22); + when Reloc_Disp30 => + Set_Wdisp (Sect, Addr, Sym, 30); + when Reloc_Hi22 => + Write_Left_Be32 (Sect, Addr, 22, Get_Symbol_Vaddr (Sym) / 1024); + when Reloc_Lo10 => + Write_Left_Be32 (Sect, Addr, 10, Get_Symbol_Vaddr (Sym)); + when Reloc_Ua_32 => + Write_Be32 (Sect, Addr, Get_Symbol_Vaddr (Sym)); + when Reloc_Ppc_Addr24 => + raise Program_Error; + end case; + end Do_Reloc; + + function Is_Reloc_Relative (Reloc : Reloc_Acc) return Boolean is + begin + case Reloc.Kind is + when Reloc_Pc32 + | Reloc_Disp22 + | Reloc_Disp30 => + return True; + when others => + return False; + end case; + end Is_Reloc_Relative; + + procedure Apply_Reloc (Sect : Section_Acc; Reloc : Reloc_Acc) is + begin + Do_Reloc (Reloc.Kind, Sect, Reloc.Addr, Reloc.Sym); + end Apply_Reloc; + + procedure Do_Intra_Section_Reloc (Sect : Section_Acc) + is + Prev : Reloc_Acc; + Rel : Reloc_Acc; + Next : Reloc_Acc; + begin + Rel := Sect.First_Reloc; + Prev := null; + while Rel /= null loop + Next := Rel.Sect_Next; + if Get_Scope (Rel.Sym) /= Sym_Undef then + Do_Reloc (Rel.Kind, Sect, Rel.Addr, Rel.Sym); + Rel.Done := True; + + if Get_Section (Rel.Sym) = Sect + and then Is_Reloc_Relative (Rel) + then + -- Remove reloc. + Sect.Nbr_Relocs := Sect.Nbr_Relocs - 1; + if Prev = null then + Sect.First_Reloc := Next; + else + Prev.Sect_Next := Next; + end if; + if Next = null then + Sect.Last_Reloc := Prev; + end if; + Free (Rel); + else + Prev := Rel; + end if; + else + Set_Used (Rel.Sym, True); + Prev := Rel; + end if; + Rel := Next; + end loop; + end Do_Intra_Section_Reloc; + + -- Return VAL rounded up to 2 ^ POW. +-- function Align_Pow (Val : Integer; Pow : Natural) return Integer +-- is +-- N : Integer; +-- Tmp : Integer; +-- begin +-- N := 2 ** Pow; +-- Tmp := Val + N - 1; +-- return Tmp - (Tmp mod N); +-- end Align_Pow; + procedure Disp_Stats + is + use Ada.Text_IO; + begin + Put_Line ("Number of Symbols: " & Symbol'Image (Symbols.Last)); + end Disp_Stats; + + procedure Finish + is + Sect : Section_Acc; + Rel, N_Rel : Reloc_Acc; + Old_Rel : Reloc_Acc; + begin + Symbols.Free; + Sect := Section_Chain; + while Sect /= null loop + -- Free relocs. + Rel := Sect.First_Reloc; + while Rel /= null loop + N_Rel := Rel.Sect_Next; + Old_Rel := Rel; + Free (Rel); + Rel := N_Rel; + end loop; + Sect.First_Reloc := null; + Sect.Last_Reloc := null; + + Sect := Sect.Next; + end loop; + end Finish; +end Binary_File; diff --git a/ortho/mcode/binary_file.ads b/ortho/mcode/binary_file.ads new file mode 100644 index 0000000..1433627 --- /dev/null +++ b/ortho/mcode/binary_file.ads @@ -0,0 +1,305 @@ +-- Binary file handling. +-- 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 Interfaces; use Interfaces; +with Ada.Unchecked_Deallocation; +with Ortho_Ident; use Ortho_Ident; +with GNAT.Table; +with System.Storage_Elements; +with Memsegs; + +package Binary_File is + type Section_Type is limited private; + type Section_Acc is access Section_Type; + + type Section_Flags is new Unsigned_32; + Section_None : constant Section_Flags; + Section_Exec : constant Section_Flags; + Section_Read : constant Section_Flags; + Section_Write : constant Section_Flags; + Section_Zero : constant Section_Flags; + Section_Strtab : constant Section_Flags; + + type Byte is new Unsigned_8; + + type Symbol is range -2 ** 31 .. 2 ** 31 - 1; + for Symbol'Size use 32; + Null_Symbol : constant Symbol := 0; + + type Pc_Type is mod System.Memory_Size; + Null_Pc : constant Pc_Type := 0; + + type Arch_Kind is (Arch_Unknown, Arch_X86, Arch_Sparc, Arch_Ppc); + Arch : Arch_Kind := Arch_Unknown; + + -- Dump assembly when generated. + Dump_Asm : Boolean := False; + + Debug_Hex : Boolean := False; + + -- Create a section. + procedure Create_Section (Sect : out Section_Acc; + Name : String; Flags : Section_Flags); + procedure Set_Section_Info (Sect : Section_Acc; + Link : Section_Acc; + Align : Natural; + Esize : Natural); + + procedure Merge_Section (Dest : Section_Acc; Src : in out Section_Acc); + + -- Set the current section. + procedure Set_Current_Section (Sect : Section_Acc); + + -- Create an undefined local (anonymous) symbol in the current section. + function Create_Local_Symbol return Symbol; + function Create_Symbol (Name : O_Ident) return Symbol; + + -- Research symbol NAME, very expansive call. + -- Return NULL_Symbol if not found. + function Get_Symbol (Name : String) return Symbol; + + -- Get the virtual address of a symbol. + function Get_Symbol_Vaddr (Sym : Symbol) return Unsigned_32; + pragma Inline (Get_Symbol_Vaddr); + + -- Set the value of a symbol. + procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean); + function Get_Symbol_Value (Sym : Symbol) return Pc_Type; + + -- Get the current PC. + function Get_Current_Pc return Pc_Type; + pragma Inline (Get_Current_Pc); + + function Get_Pc (Sect : Section_Acc) return Pc_Type; + pragma Inline (Get_Pc); + + -- Align the current section of 2 ** ALIGN. + procedure Gen_Pow_Align (Align : Natural); + + -- Generate LENGTH times 0. + procedure Gen_Space (Length : Integer_32); + + -- Add a reloc in the current section at the current address. + procedure Gen_X86_Pc32 (Sym : Symbol); + procedure Gen_Sparc_Disp22 (W : Unsigned_32; Sym : Symbol); + procedure Gen_Sparc_Disp30 (W : Unsigned_32; Sym : Symbol); + procedure Gen_Sparc_Hi22 (W : Unsigned_32; + Sym : Symbol; Off : Unsigned_32); + procedure Gen_Sparc_Lo10 (W : Unsigned_32; + Sym : Symbol; Off : Unsigned_32); + + -- Add a 32 bits value with a symbol relocation in the current section at + -- the current address. + procedure Gen_X86_32 (Sym : Symbol; Offset : Integer_32); + procedure Gen_Sparc_32 (Sym : Symbol; Offset : Integer_32); + procedure Gen_Sparc_Ua_32 (Sym : Symbol; Offset : Integer_32); + + procedure Gen_Ppc_24 (V : Unsigned_32; Sym : Symbol); + + procedure Gen_Ua_32 (Sym : Symbol; Offset : Integer_32); + + -- Start/finish an instruction in the current section. + procedure Start_Insn; + procedure End_Insn; + -- Pre allocate L bytes. + procedure Prealloc (L : Pc_Type); + + -- Add bits in the current section. + procedure Gen_B8 (B : Byte); + procedure Gen_B16 (B0, B1 : Byte); + procedure Gen_Le8 (B : Unsigned_32); + procedure Gen_Le16 (B : Unsigned_32); + procedure Gen_Be16 (B : Unsigned_32); + procedure Gen_Le32 (B : Unsigned_32); + procedure Gen_Be32 (B : Unsigned_32); + + procedure Gen_16 (B : Unsigned_32); + procedure Gen_32 (B : Unsigned_32); + + -- Add bits in the current section, but as stand-alone data. + procedure Gen_Data_Le8 (B : Unsigned_32); + procedure Gen_Data_Le16 (B : Unsigned_32); + procedure Gen_Data_32 (Sym : Symbol; Offset : Integer_32); + + -- Modify already generated code. + procedure Patch_B8 (Pc : Pc_Type; V : Unsigned_8); + procedure Patch_Le32 (Pc : Pc_Type; V : Unsigned_32); + procedure Patch_Be32 (Pc : Pc_Type; V : Unsigned_32); + procedure Patch_Be16 (Pc : Pc_Type; V : Unsigned_32); + procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32); + + -- Binary writers: + + -- Set ERROR in case of error (undefined symbol). + --procedure Write_Memory (Error : out Boolean); + + procedure Disp_Stats; + procedure Finish; +private + package SSE renames System.Storage_Elements; + + type Byte_Array_Base is array (Pc_Type range <>) of Byte; + subtype Byte_Array is Byte_Array_Base (Pc_Type); + type Byte_Array_Acc is access Byte_Array; + type String_Acc is access String; + --type Section_Flags is new Unsigned_32; + + -- Relocations. + type Reloc_Kind is (Reloc_32, Reloc_Pc32, + Reloc_Ua_32, + Reloc_Disp22, Reloc_Disp30, + Reloc_Hi22, Reloc_Lo10, + Reloc_Ppc_Addr24); + type Reloc_Type; + type Reloc_Acc is access Reloc_Type; + type Reloc_Type is record + Kind : Reloc_Kind; + -- If true, the reloc was already applied. + Done : Boolean; + -- Next in simply linked list. + -- next reloc in the section. + Sect_Next : Reloc_Acc; + -- next reloc for the symbol. + Sym_Next : Reloc_Acc; + -- Address that must be relocated. + Addr : Pc_Type; + -- Symbol. + Sym : Symbol; + end record; + + type Section_Type is record + -- Simply linked list of sections. + Next : Section_Acc; + -- Flags. + Flags : Section_Flags; + -- Name of the section. + Name : String_Acc; + -- Link to another section (used by ELF). + Link : Section_Acc; + -- Alignment (in power of 2). + Align : Natural; + -- Entry size (if any). + Esize : Natural; + -- Offset of the next data in DATA. + Pc : Pc_Type; + -- Offset of the current instruction. + Insn_Pc : Pc_Type; + -- Data for this section. + Data : Byte_Array_Acc; + -- Max address for data (before extending the area). + Data_Max : Pc_Type; + -- Chain of relocs defined in this section. + First_Reloc : Reloc_Acc; + Last_Reloc : Reloc_Acc; + -- Number of relocs in this section. + Nbr_Relocs : Natural; + -- Section number (set and used by binary writer). + Number : Natural; + -- Virtual address, if set. + Vaddr : SSE.Integer_Address; + -- Memory for this segment. + Seg : Memsegs.Memseg_Type; + end record; + + Section_Exec : constant Section_Flags := 2#0000_0001#; + Section_Read : constant Section_Flags := 2#0000_0010#; + Section_Write : constant Section_Flags := 2#0000_0100#; + Section_Zero : constant Section_Flags := 2#0000_1000#; + Section_Strtab : constant Section_Flags := 2#0001_0000#; + Section_None : constant Section_Flags := 2#0000_0000#; + + -- Scope of a symbol: + -- SYM_PRIVATE: not visible outside of the file. + -- SYM_UNDEF: not (yet) defined, unresolved. + -- SYM_GLOBAL: visible to all files. + -- SYM_LOCAL: locally generated symbol. + type Symbol_Scope is (Sym_Undef, Sym_Global, Sym_Private, Sym_Local); + subtype Symbol_Scope_External is Symbol_Scope range Sym_Undef .. Sym_Global; + type Symbol_Type is record + Section : Section_Acc; + Value : Pc_Type; + Scope : Symbol_Scope; + -- True if the symbol is referenced/used. + Used : Boolean; + -- Name of the symbol. + Name : O_Ident; + -- List of relocation made with this symbol. + Relocs : Reloc_Acc; + -- Symbol number, from 0. + Number : Natural; + end record; + + -- Number of sections. + Nbr_Sections : Natural := 0; + -- Simply linked list of sections. + Section_Chain : Section_Acc := null; + Section_Last : Section_Acc := null; + + package Symbols is new GNAT.Table + (Table_Component_Type => Symbol_Type, + Table_Index_Type => Symbol, + Table_Low_Bound => 2, + Table_Initial => 1024, + Table_Increment => 100); + + function Pow_Align (V : Pc_Type; Align : Natural) return Pc_Type; + + function Get_Symbol_Name (Sym : Symbol) return String; + function Get_Symbol_Name_Length (Sym : Symbol) return Natural; + + procedure Set_Symbol_Value (Sym : Symbol; Val : Pc_Type); + pragma Inline (Set_Symbol_Value); + + procedure Set_Scope (Sym : Symbol; Scope : Symbol_Scope); + pragma Inline (Set_Scope); + + function Get_Scope (Sym : Symbol) return Symbol_Scope; + pragma Inline (Get_Scope); + + function Get_Section (Sym : Symbol) return Section_Acc; + pragma Inline (Get_Section); + + procedure Set_Section (Sym : Symbol; Sect : Section_Acc); + pragma Inline (Set_Section); + + function Get_Name (Sym : Symbol) return O_Ident; + pragma Inline (Get_Name); + + procedure Apply_Reloc (Sect : Section_Acc; Reloc : Reloc_Acc); + pragma Inline (Apply_Reloc); + + procedure Set_Number (Sym : Symbol; Num : Natural); + pragma Inline (Set_Number); + + function Get_Number (Sym : Symbol) return Natural; + pragma Inline (Get_Number); + + function Get_Used (Sym : Symbol) return Boolean; + pragma Inline (Get_Used); + + procedure Do_Intra_Section_Reloc (Sect : Section_Acc); + + function S_Local (Sym : Symbol) return Boolean; + pragma Inline (S_Local); + + procedure Resize (Sect : Section_Acc; Size : Pc_Type); + + procedure Free is new Ada.Unchecked_Deallocation + (Name => Reloc_Acc, Object => Reloc_Type); + + Write_Error : exception; +end Binary_File; diff --git a/ortho/mcode/coff.ads b/ortho/mcode/coff.ads new file mode 100644 index 0000000..6ef9cdd --- /dev/null +++ b/ortho/mcode/coff.ads @@ -0,0 +1,208 @@ +-- COFF definitions. +-- 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 Interfaces; use Interfaces; +with System; use System; + +package Coff is + type Filehdr is record + F_Magic : Unsigned_16; -- Magic number. + F_Nscns : Unsigned_16; -- Number of sections. + F_Timdat : Unsigned_32; -- Time and date stamp. + F_Symptr : Unsigned_32; -- File pointer to symtab. + F_Nsyms : Unsigned_32; -- Number of symtab entries. + F_Opthdr : Unsigned_16; -- Size of optionnal header. + F_Flags : Unsigned_16; -- Flags; + end record; + + -- Size of Filehdr. + Filehdr_Size : constant Natural := Filehdr'Size / Storage_Unit; + + -- Magic numbers. + I386magic : constant Unsigned_16 := 16#014c#; + + -- Flags of file header. + -- Relocation info stripped from file. + F_Relflg : constant Unsigned_16 := 16#0001#; + + -- File is executable (no unresolved symbols). + F_Exec : constant Unsigned_16 := 16#0002#; + + -- Line numbers stripped from file. + F_Lnno : constant Unsigned_16 := 16#0004#; + + -- Local symbols stripped from file. + F_Lsyms : constant Unsigned_16 := 16#0008#; + + type Scnhdr is record + S_Name : String (1 .. 8); -- Section name. + S_Paddr : Unsigned_32; -- Physical address. + S_Vaddr : Unsigned_32; -- Virtual address. + S_Size : Unsigned_32; -- Section size. + S_Scnptr : Unsigned_32; -- File pointer to raw section data. + S_Relptr : Unsigned_32; -- File pointer to relocation data. + S_Lnnoptr : Unsigned_32; -- File pointer to line number data. + S_Nreloc : Unsigned_16; -- Number of relocation entries. + S_Nlnno : Unsigned_16; -- Number of line number entries. + S_Flags : Unsigned_32; -- Flags. + end record; + Scnhdr_Size : constant Natural := Scnhdr'Size / Storage_Unit; + + -- section contains text only. + STYP_TEXT : constant Unsigned_32 := 16#0020#; + -- section contains data only. + STYP_DATA : constant Unsigned_32 := 16#0040#; + -- section contains bss only. + STYP_BSS : constant Unsigned_32 := 16#0080#; + + type Strent_Type is record + E_Zeroes : Unsigned_32; + E_Offset : Unsigned_32; + end record; + + type Sym_Name (Inline : Boolean := True) is record + case Inline is + when True => + E_Name : String (1 .. 8); + when False => + E : Strent_Type; + end case; + end record; + pragma Unchecked_Union (Sym_Name); + for Sym_Name'Size use 64; + + type Syment is record + E : Sym_Name; -- Name of the symbol + E_Value : Unsigned_32; -- Value + E_Scnum : Unsigned_16; -- Section + E_Type : Unsigned_16; + E_Sclass : Unsigned_8; + E_Numaux : Unsigned_8; + end record; + Symesz : constant Natural := 18; + for Syment'Size use Symesz * Storage_Unit; + + -- An undefined (extern) symbol. + N_UNDEF : constant Unsigned_16 := 16#00_00#; + -- An absolute symbol (e_value is a constant, not an address). + N_ABS : constant Unsigned_16 := 16#Ff_Ff#; + -- A debugging symbol. + N_DEBUG : constant Unsigned_16 := 16#Ff_Fe#; + + C_NULL : constant Unsigned_8 := 0; + C_AUTO : constant Unsigned_8 := 1; + C_EXT : constant Unsigned_8 := 2; + C_STAT : constant Unsigned_8 := 3; + C_REG : constant Unsigned_8 := 4; + C_EXTDEF : constant Unsigned_8 := 5; + C_LABEL : constant Unsigned_8 := 6; + C_ULABEL : constant Unsigned_8 := 7; + C_MOS : constant Unsigned_8 := 8; + C_ARG : constant Unsigned_8 := 9; + C_STRTAG : constant Unsigned_8 := 10; + C_MOU : constant Unsigned_8 := 11; + C_UNTAG : constant Unsigned_8 := 12; + C_TPDEF : constant Unsigned_8 := 13; + C_USTATIC : constant Unsigned_8 := 14; + C_ENTAG : constant Unsigned_8 := 15; + C_MOE : constant Unsigned_8 := 16; + C_REGPARM : constant Unsigned_8 := 17; + C_FIELD : constant Unsigned_8 := 18; + C_AUTOARG : constant Unsigned_8 := 19; + C_LASTENT : constant Unsigned_8 := 20; + C_BLOCK : constant Unsigned_8 := 100; + C_FCN : constant Unsigned_8 := 101; + C_EOS : constant Unsigned_8 := 102; + C_FILE : constant Unsigned_8 := 103; + C_LINE : constant Unsigned_8 := 104; + C_ALIAS : constant Unsigned_8 := 105; + C_HIDDEN : constant Unsigned_8 := 106; + C_EFCN : constant Unsigned_8 := 255; + + -- Textual description of sclass. + type Const_String_Acc is access constant String; + type Sclass_Desc_Type is record + Name : Const_String_Acc; + Meaning : Const_String_Acc; + end record; + type Sclass_Desc_Array_Type is array (Unsigned_8) of Sclass_Desc_Type; + Sclass_Desc : constant Sclass_Desc_Array_Type; + + type Auxent_File (Inline : Boolean := True) is record + case Inline is + when True => + X_Fname : String (1 .. 14); + when False => + X_N : Strent_Type; + end case; + end record; + pragma Unchecked_Union (Auxent_File); + + type Auxent_Scn is record + X_Scnlen : Unsigned_32; + X_Nreloc : Unsigned_16; + X_Nlinno : Unsigned_16; + end record; + + -- Relocation. + type Reloc is record + R_Vaddr : Unsigned_32; + R_Symndx : Unsigned_32; + R_Type : Unsigned_16; + end record; + Relsz : constant Natural := Reloc'Size / Storage_Unit; + + Reloc_Rel32 : constant Unsigned_16 := 20; + Reloc_Addr32 : constant Unsigned_16 := 6; + +private + subtype S is String; + Sclass_Desc : constant Sclass_Desc_Array_Type := + (C_NULL => (new S'("C_NULL"), new S'("No entry")), + C_AUTO => (new S'("C_AUTO"), new S'("Automatic variable")), + C_EXT => (new S'("C_EXT"), new S'("External/public symbol")), + C_STAT => (new S'("C_STAT"), new S'("static (private) symbol")), + C_REG => (new S'("C_REG"), new S'("register variable")), + C_EXTDEF => (new S'("C_EXTDEF"), new S'("External definition")), + C_LABEL => (new S'("C_LABEL"), new S'("label")), + C_ULABEL => (new S'("C_ULABEL"), new S'("undefined label")), + C_MOS => (new S'("C_MOS"), new S'("member of structure")), + C_ARG => (new S'("C_ARG"), new S'("function argument")), + C_STRTAG => (new S'("C_STRTAG"), new S'("structure tag")), + C_MOU => (new S'("C_MOU"), new S'("member of union")), + C_UNTAG => (new S'("C_UNTAG"), new S'("union tag")), + C_TPDEF => (new S'("C_TPDEF"), new S'("type definition")), + C_USTATIC => (new S'("C_USTATIC"), new S'("undefined static")), + C_ENTAG => (new S'("C_ENTAG"), new S'("enumaration tag")), + C_MOE => (new S'("C_MOE"), new S'("member of enumeration")), + C_REGPARM => (new S'("C_REGPARM"), new S'("register parameter")), + C_FIELD => (new S'("C_FIELD"), new S'("bit field")), + C_AUTOARG => (new S'("C_AUTOARG"), new S'("auto argument")), + C_LASTENT => (new S'("C_LASTENT"), new S'("dummy entry (end of block)")), + C_BLOCK => (new S'("C_BLOCK"), new S'("beginning or end of block")), + C_FCN => (new S'("C_FCN"), new S'("beginning or end of function")), + C_EOS => (new S'("C_EOS"), new S'("end of structure")), + C_FILE => (new S'("C_FILE"), new S'("file name")), + C_LINE => (new S'("C_LINE"), + new S'("line number, reformatted as symbol")), + C_ALIAS => (new S'("C_ALIAS"), new S'("duplicate tag")), + C_HIDDEN => (new S'("C_HIDDEN"), + new S'("ext symbol in dmert public lib")), + C_EFCN => (new S'("C_EFCN"), new S'("physical end of function")), + others => (null, null)); + +end Coff; diff --git a/ortho/mcode/coffdump.adb b/ortho/mcode/coffdump.adb new file mode 100644 index 0000000..6384b6c --- /dev/null +++ b/ortho/mcode/coffdump.adb @@ -0,0 +1,274 @@ +-- COFF dumper. +-- 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 Coff; use Coff; +with Interfaces; use Interfaces; +with System; +with Ada.Unchecked_Conversion; +with Ada.Command_Line; use Ada.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Ada.Text_IO; use Ada.Text_IO; +with Hex_Images; use Hex_Images; + +procedure Coffdump is + type Cstring is array (Unsigned_32 range <>) of Character; + type Cstring_Acc is access Cstring; + type Section_Array is array (Unsigned_16 range <>) of Scnhdr; + type Section_Array_Acc is access Section_Array; + -- Array of sections. + Sections : Section_Array_Acc; + + type External_Symbol is array (0 .. Symesz - 1) of Character; + type External_Symbol_Array is array (Unsigned_32 range <>) + of External_Symbol; + type Symbol_Array_Acc is access External_Symbol_Array; + -- Symbols table. + External_Symbols : Symbol_Array_Acc; + + -- String table. + Str : Cstring_Acc; + Str_Size : Natural; + + Hdr : Filehdr; + --Sym : Syment; + Fd : File_Descriptor; + Skip : Natural; + Skip_Kind : Unsigned_8; + Aux_File : Auxent_File; + Aux_Scn : Auxent_Scn; + Rel : Reloc; + Len : Natural; + + Nul : constant Character := Character'Val (0); + + function Find_Nul (S : String) return String is + begin + for I in S'Range loop + if S (I) = Nul then + return S (S'First .. I - 1); + end if; + end loop; + return S; + end Find_Nul; + + function Get_String (N : Strent_Type; S : String) return String + is + begin + if N.E_Zeroes /= 0 then + return Find_Nul (S); + else + for I in N.E_Offset .. Str'Last loop + if Str (I) = Nul then + return String (Str (N.E_Offset .. I - 1)); + end if; + end loop; + raise Program_Error; + end if; + end Get_String; + + procedure Memcpy + (Dst : System.Address; Src : System.Address; Size : Natural); + pragma Import (C, Memcpy); + + function Get_Section_Name (N : Unsigned_16) return String is + begin + if N = N_UNDEF then + return "UNDEF"; + elsif N = N_ABS then + return "ABS"; + elsif N = N_DEBUG then + return "DEBUG"; + elsif N > Hdr.F_Nscns then + return "???"; + else + return Find_Nul (Sections (N).S_Name); + end if; + end Get_Section_Name; + + function Get_Symbol (N : Unsigned_32) return Syment is + function Unchecked_Conv is new Ada.Unchecked_Conversion + (Source => External_Symbol, Target => Syment); + begin + if N > Hdr.F_Nsyms then + raise Constraint_Error; + end if; + return Unchecked_Conv (External_Symbols (N)); + end Get_Symbol; + + function Get_Symbol_Name (N : Unsigned_32) return String + is + S : Syment := Get_Symbol (N); + begin + return Get_String (S.E.E, S.E.E_Name); + end Get_Symbol_Name; +begin + for I in 1 .. Argument_Count loop + Fd := Open_Read (Argument (I), Binary); + if Fd = Invalid_FD then + Put_Line ("cannot open " & Argument (I)); + return; + end if; + -- Read file header. + if Read (Fd, Hdr'Address, Filehdr_Size) /= Filehdr_Size then + Put_Line ("cannot read header"); + return; + end if; + Put_Line ("File: " & Argument (I)); + Put_Line ("magic: " & Hex_Image (Hdr.F_Magic)); + Put_Line ("number of sections: " & Hex_Image (Hdr.F_Nscns)); + Put_Line ("time and date stamp: " & Hex_Image (Hdr.F_Timdat)); + Put_Line ("symtab file pointer: " & Hex_Image (Hdr.F_Symptr)); + Put_Line ("nbr symtab entries: " & Hex_Image (Hdr.F_Nsyms)); + Put_Line ("opt header size: " & Hex_Image (Hdr.F_Opthdr)); + Put_Line ("flags: " & Hex_Image (Hdr.F_Flags)); + + -- Read sections header. + Lseek (Fd, Long_Integer (Hdr.F_Opthdr), Seek_Cur); + Sections := new Section_Array (1 .. Hdr.F_Nscns); + Len := Scnhdr_Size * Natural (Hdr.F_Nscns); + if Read (Fd, Sections (1)'Address, Len) /= Len then + Put_Line ("cannot read section header"); + return; + end if; + for I in 1 .. Hdr.F_Nscns loop + declare + S: Scnhdr renames Sections (I); + begin + Put_Line ("Section " & Find_Nul (S.S_Name)); + Put_Line ("Physical address : " & Hex_Image (S.S_Paddr)); + Put_Line ("Virtual address : " & Hex_Image (S.S_Vaddr)); + Put_Line ("section size : " & Hex_Image (S.S_Size)); + Put_Line ("section pointer : " & Hex_Image (S.S_Scnptr)); + Put_Line ("relocation pointer : " & Hex_Image (S.S_Relptr)); + Put_Line ("line num pointer : " & Hex_Image (S.S_Lnnoptr)); + Put_Line ("Nbr reloc entries : " & Hex_Image (S.S_Nreloc)); + Put_Line ("Nbr line num entries : " & Hex_Image (S.S_Nlnno)); + Put_Line ("Flags : " & Hex_Image (S.S_Flags)); + end; + end loop; + + -- Read string table. + Lseek (Fd, + Long_Integer (Hdr.F_Symptr + Hdr.F_Nsyms * Unsigned_32 (Symesz)), + Seek_Set); + if Read (Fd, Str_Size'Address, 4) /= 4 then + Put_Line ("cannot read string table size"); + return; + end if; + Str := new Cstring (0 .. Unsigned_32 (Str_Size)); + if Read (Fd, Str (4)'Address, Str_Size - 4) /= Str_Size - 4 then + Put_Line ("cannot read string table"); + return; + end if; + + -- Read symbol table. + Lseek (Fd, Long_Integer (Hdr.F_Symptr), Seek_Set); + External_Symbols := new External_Symbol_Array (0 .. Hdr.F_Nsyms - 1); + Len := Natural (Hdr.F_Nsyms) * Symesz; + if Read (Fd, External_Symbols (0)'Address, Len) /= Len then + Put_Line ("cannot read symbol"); + return; + end if; + + Skip := 0; + Skip_Kind := C_NULL; + for I in External_Symbols'range loop + if Skip > 0 then + case Skip_Kind is + when C_FILE => + Memcpy (Aux_File'Address, External_Symbols (I)'Address, + Aux_File'Size / 8); + Put_Line ("aux file : " & Get_String (Aux_File.X_N, + Aux_File.X_Fname)); + Skip_Kind := C_NULL; + when C_STAT => + Memcpy (Aux_Scn'Address, External_Symbols (I)'Address, + Aux_Scn'Size / 8); + Put_Line ("section len: " & Hex_Image (Aux_Scn.X_Scnlen)); + Put_Line ("nbr reloc ent: " & Hex_Image (Aux_Scn.X_Nreloc)); + Put_Line ("nbr line num: " & Hex_Image (Aux_Scn.X_Nlinno)); + when others => + Put_Line ("skip"); + end case; + Skip := Skip - 1; + else + declare + S : Syment := Get_Symbol (I); + begin + Put_Line ("Symbol #" & Hex_Image (I)); + Put_Line ("symbol name : " & Get_Symbol_Name (I)); + Put_Line ("symbol value: " & Hex_Image (S.E_Value)); + Put_Line ("section num : " & Hex_Image (S.E_Scnum) + & " " & Get_Section_Name (S.E_Scnum)); + Put_Line ("type : " & Hex_Image (S.E_Type)); + Put ("sclass : " & Hex_Image (S.E_Sclass)); + if Sclass_Desc (S.E_Sclass).Name /= null then + Put (" ("); + Put (Sclass_Desc (S.E_Sclass).Name.all); + Put (" - "); + Put (Sclass_Desc (S.E_Sclass).Meaning.all); + Put (")"); + end if; + New_Line; + Put_Line ("numaux : " & Hex_Image (S.E_Numaux)); + if S.E_Numaux > 0 then + case S.E_Sclass is + when C_FILE => + Skip_Kind := C_FILE; + when C_STAT => + Skip_Kind := C_STAT; + when others => + Skip_Kind := C_NULL; + end case; + end if; + Skip := Natural (S.E_Numaux); + end; + end if; + end loop; + + -- Disp relocs. + for I in 1 .. Hdr.F_Nscns loop + if Sections (I).S_Nreloc > 0 then + -- Read relocations. + Put_Line ("Relocations for section " & Get_Section_Name (I)); + Lseek (Fd, Long_Integer (Sections (I).S_Relptr), Seek_Set); + for J in 1 .. Sections (I).S_Nreloc loop + if Read (Fd, Rel'Address, Relsz) /= Relsz then + Put_Line ("cannot read reloc"); + return; + end if; + Put_Line ("reloc virtual addr: " & Hex_Image (Rel.R_Vaddr)); + Put_Line ("symbol index : " & Hex_Image (Rel.R_Symndx) + & " " & Get_Symbol_Name (Rel.R_Symndx)); + Put ("type of relocation: " & Hex_Image (Rel.R_Type)); + case Rel.R_Type is + when Reloc_Rel32 => + Put (" RELOC_REL32"); + when Reloc_Addr32 => + Put (" RELOC_ADDR32"); + when others => + null; + end case; + New_Line; + end loop; + end if; + end loop; + + Close (Fd); + end loop; +end Coffdump; + diff --git a/ortho/mcode/disa_sparc.adb b/ortho/mcode/disa_sparc.adb new file mode 100644 index 0000000..8c9176f --- /dev/null +++ b/ortho/mcode/disa_sparc.adb @@ -0,0 +1,274 @@ +with System; use System; +with Interfaces; use Interfaces; +with Ada.Unchecked_Conversion; +with Hex_Images; use Hex_Images; + +package body Disa_Sparc is + subtype Reg_Type is Unsigned_32 range 0 .. 31; + + type Hex_Map_Type is array (Unsigned_32 range 0 .. 15) of Character; + Hex_Digit : constant Hex_Map_Type := "0123456789abcdef"; + + type Cstring_Acc is access constant String; + type Cond_Map_Type is array (Unsigned_32 range 0 .. 15) of Cstring_Acc; + subtype S is String; + Bicc_Map : constant Cond_Map_Type := + (0 => new S'("n"), + 1 => new S'("e"), + 2 => new S'("le"), + 3 => new S'("l"), + 4 => new S'("leu"), + 5 => new S'("cs"), + 6 => new S'("neg"), + 7 => new S'("vs"), + 8 => new S'("a"), + 9 => new S'("ne"), + 10 => new S'("g"), + 11 => new S'("ge"), + 12 => new S'("gu"), + 13 => new S'("cc"), + 14 => new S'("pos"), + 15 => new S'("vc") + ); + + + type Format_Type is + ( + Format_Bad, + Format_Regimm, -- format 3, rd, rs1, rs2 or imm13 + Format_Rd, -- format 3, rd only. + Format_Copro, -- format 3, fpu or coprocessor + Format_Asi -- format 3, rd, rs1, asi and rs2. + ); + + type Insn_Desc_Type is record + Name : Cstring_Acc; + Format : Format_Type; + end record; + + type Insn_Desc_Array is array (Unsigned_32 range 0 .. 63) of Insn_Desc_Type; + Insn_Desc_10 : constant Insn_Desc_Array := + ( + 2#000_000# => (new S'("add"), Format_Regimm), + 2#000_001# => (new S'("and"), Format_Regimm), + 2#000_010# => (new S'("or"), Format_Regimm), + 2#000_011# => (new S'("xor"), Format_Regimm), + 2#000_100# => (new S'("sub"), Format_Regimm), + 2#000_101# => (new S'("andn"), Format_Regimm), + 2#000_110# => (new S'("orn"), Format_Regimm), + 2#000_111# => (new S'("xnor"), Format_Regimm), + 2#001_000# => (new S'("addx"), Format_Regimm), + + 2#001_100# => (new S'("subx"), Format_Regimm), + + 2#010_000# => (new S'("addcc"), Format_Regimm), + 2#010_001# => (new S'("andcc"), Format_Regimm), + 2#010_010# => (new S'("orcc"), Format_Regimm), + 2#010_011# => (new S'("xorcc"), Format_Regimm), + 2#010_100# => (new S'("subcc"), Format_Regimm), + 2#010_101# => (new S'("andncc"), Format_Regimm), + 2#010_110# => (new S'("orncc"), Format_Regimm), + 2#010_111# => (new S'("xnorcc"), Format_Regimm), + 2#011_000# => (new S'("addxcc"), Format_Regimm), + + 2#011_100# => (new S'("subxcc"), Format_Regimm), + + 2#111_000# => (new S'("jmpl"), Format_Regimm), + + 2#111_100# => (new S'("save"), Format_Regimm), + 2#111_101# => (new S'("restore"), Format_Regimm), + + others => (null, Format_Bad) + ); + + Insn_Desc_11 : constant Insn_Desc_Array := + ( + 2#000_000# => (new S'("ld"), Format_Regimm), + 2#000_001# => (new S'("ldub"), Format_Regimm), + 2#000_010# => (new S'("lduh"), Format_Regimm), + 2#000_011# => (new S'("ldd"), Format_Regimm), + 2#000_100# => (new S'("st"), Format_Regimm), + 2#000_101# => (new S'("stb"), Format_Regimm), + + 2#010_000# => (new S'("lda"), Format_Asi), + 2#010_011# => (new S'("ldda"), Format_Asi), + + 2#110_000# => (new S'("ldc"), Format_Regimm), + 2#110_001# => (new S'("ldcsr"), Format_Regimm), + + others => (null, Format_Bad) + ); + + -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN. + procedure Disassemble_Insn (Addr : Address; + Line : in out String; + Line_Len : out Natural; + Insn_Len : out Natural; + Proc_Cb : Symbol_Proc_Type) + is + type Unsigned_32_Acc is access Unsigned_32; + function To_Unsigned_32_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Unsigned_32_Acc); + + W : Unsigned_32; + Lo : Natural; + + -- Add CHAR to the line. + procedure Add_Char (C : Character); + pragma Inline (Add_Char); + + procedure Add_Char (C : Character) is + begin + Line (Lo) := C; + Lo := Lo + 1; + end Add_Char; + + -- Add STR to the line. + procedure Add_String (Str : String) is + begin + Line (Lo .. Lo + Str'Length - 1) := Str; + Lo := Lo + Str'Length; + end Add_String; + + -- Add BYTE to the line. +-- procedure Add_Byte (V : Byte) is +-- type My_Str is array (Natural range 0 .. 15) of Character; +-- Hex_Digit : constant My_Str := "0123456789abcdef"; +-- begin +-- Add_Char (Hex_Digit (Natural (Shift_Right (V, 4) and 16#0f#))); +-- Add_Char (Hex_Digit (Natural (Shift_Right (V, 0) and 16#0f#))); +-- end Add_Byte; + + procedure Disp_Const (Mask : Unsigned_32) + is + L : Natural; + V : Unsigned_32; + begin + L := Lo; + Proc_Cb.all (Addr, Line (Lo .. Line'Last), Lo); + V := W and Mask; + + -- Extend sign. + if (W and ((Mask + 1) / 2)) /= 0 then + V := V or not Mask; + end if; + if L /= Lo then + if V = 0 then + return; + end if; + Add_String (" + "); + end if; + Add_String ("0x"); + Add_String (Hex_Image (V)); + end Disp_Const; + + procedure Add_Cond (Str : String) + is + begin + Add_String (Str); + Add_String (Bicc_Map (Shift_Right (W, 25) and 2#1111#).all); + if (W and 16#2000_0000#) /= 0 then + Add_String (",a"); + end if; + Add_Char (' '); + Disp_Const (16#3f_Ffff#); + end Add_Cond; + + + procedure Add_Ireg (R : Reg_Type) + is + begin + Add_Char ('%'); + if R <= 7 then + Add_Char ('g'); + elsif R <= 15 then + if R = 14 then + Add_String ("sp"); + return; + else + Add_Char ('o'); + end if; + elsif R <= 23 then + Add_Char ('l'); + else + if R = 30 then + Add_String ("fp"); + return; + else + Add_Char ('i'); + end if; + end if; + Add_Char (Hex_Digit (R and 7)); + end Add_Ireg; + + procedure Disp_Unknown is + begin + Add_String ("unknown "); + Add_String (Hex_Image (W)); + end Disp_Unknown; + + procedure Disp_Format3 (Map : Insn_Desc_Array) + is + Op2 : Unsigned_32 range 0 .. 63; + begin + Op2 := Shift_Right (W, 19) and 2#111_111#; + + case Map (Op2).Format is + when Format_Regimm => + Add_String (Map (Op2).Name.all); + Add_Char (' '); + Add_Ireg (Shift_Right (W, 25) and 31); + Add_Char (','); + Add_Ireg (Shift_Right (W, 14) and 31); + Add_Char (','); + if (W and 16#2000#) /= 0 then + Disp_Const (16#1fff#); + else + Add_Ireg (W and 31); + end if; + when others => + Add_String ("unknown3, op2="); + Add_String (Hex_Image (Op2)); + end case; + end Disp_Format3; + + + begin + W := To_Unsigned_32_Acc (Addr).all; + Insn_Len := 4; + Lo := Line'First; + + case Shift_Right (W, 30) is + when 2#00# => + -- BIcc, SETHI + case Shift_Right (W, 22) and 2#111# is + when 2#000# => + Add_String ("unimp "); + Disp_Const (16#3f_Ffff#); + when 2#010# => + Add_Cond ("b"); + when 2#100# => + Add_String ("sethi "); + Add_Ireg (Shift_Right (W, 25)); + Add_String (", "); + Disp_Const (16#3f_Ffff#); + when others => + Disp_Unknown; + end case; + when 2#01# => + -- Call + Add_String ("call "); + Disp_Const (16#3fff_Ffff#); + when 2#10# => + Disp_Format3 (Insn_Desc_10); + when 2#11# => + Disp_Format3 (Insn_Desc_11); + when others => + -- Misc. + Disp_Unknown; + end case; + + Line_Len := Lo - Line'First; + end Disassemble_Insn; + +end Disa_Sparc; diff --git a/ortho/mcode/disa_sparc.ads b/ortho/mcode/disa_sparc.ads new file mode 100644 index 0000000..486dff9 --- /dev/null +++ b/ortho/mcode/disa_sparc.ads @@ -0,0 +1,15 @@ +with System; + +package Disa_Sparc is + -- Call-back used to find a relocation symbol. + type Symbol_Proc_Type is access procedure (Addr : System.Address; + Line : in out String; + Line_Len : in out Natural); + + -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN. + procedure Disassemble_Insn (Addr : System.Address; + Line : in out String; + Line_Len : out Natural; + Insn_Len : out Natural; + Proc_Cb : Symbol_Proc_Type); +end Disa_Sparc; diff --git a/ortho/mcode/disa_x86.adb b/ortho/mcode/disa_x86.adb new file mode 100644 index 0000000..24c70cf --- /dev/null +++ b/ortho/mcode/disa_x86.adb @@ -0,0 +1,978 @@ +-- X86 disassembler. +-- 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 Interfaces; use Interfaces; +with System.Address_To_Access_Conversions; + +package body Disa_X86 is + type Byte is new Interfaces.Unsigned_8; + type Bf_2 is mod 2 ** 2; + type Bf_3 is mod 2 ** 3; + type Byte_Vector is array (Natural) of Byte; + package Bv_Addr2acc is new System.Address_To_Access_Conversions + (Object => Byte_Vector); + use Bv_Addr2acc; + + type Cstring_Acc is access constant String; + type Index_Type is new Natural; + type Names_Type is array (Index_Type range <>) of Cstring_Acc; + N_None : constant Index_Type := 0; + N_Push : constant Index_Type := 1; + N_Pop : constant Index_Type := 2; + N_Ret : constant Index_Type := 3; + N_Mov : constant Index_Type := 4; + N_Add : constant Index_Type := 5; + N_Or : constant Index_Type := 6; + N_Adc : constant Index_Type := 7; + N_Sbb : constant Index_Type := 8; + N_And : constant Index_Type := 9; + N_Sub : constant Index_Type := 10; + N_Xor : constant Index_Type := 11; + N_Cmp : constant Index_Type := 12; + N_Into : constant Index_Type := 13; + N_Jmp : constant Index_Type := 14; + N_Jcc : constant Index_Type := 15; + N_Setcc : constant Index_Type := 16; + N_Call : constant Index_Type := 17; + N_Int : constant Index_Type := 18; + N_Cdq : constant Index_Type := 19; + N_Imul : constant Index_Type := 20; + N_Mul : constant Index_Type := 21; + N_Leave : constant Index_Type := 22; + N_Test : constant Index_Type := 23; + N_Lea : constant Index_Type := 24; + N_O : constant Index_Type := 25; + N_No : constant Index_Type := 26; + N_B : constant Index_Type := 27; + N_AE : constant Index_Type := 28; + N_E : constant Index_Type := 29; + N_Ne : constant Index_Type := 30; + N_Be : constant Index_Type := 31; + N_A : constant Index_Type := 32; + N_S : constant Index_Type := 33; + N_Ns : constant Index_Type := 34; + N_P : constant Index_Type := 35; + N_Np : constant Index_Type := 36; + N_L : constant Index_Type := 37; + N_Ge : constant Index_Type := 38; + N_Le : constant Index_Type := 39; + N_G : constant Index_Type := 40; + N_Not : constant Index_Type := 41; + N_Neg : constant Index_Type := 42; + N_Cbw : constant Index_Type := 43; + N_Div : constant Index_Type := 44; + N_Idiv : constant Index_Type := 45; + N_Movsx : constant Index_Type := 46; + N_Movzx : constant Index_Type := 47; + N_Nop : constant Index_Type := 48; + N_Hlt : constant Index_Type := 49; + N_Inc : constant Index_Type := 50; + N_Dec : constant Index_Type := 51; + N_Rol : constant Index_Type := 52; + N_Ror : constant Index_Type := 53; + N_Rcl : constant Index_Type := 54; + N_Rcr : constant Index_Type := 55; + N_Shl : constant Index_Type := 56; + N_Shr : constant Index_Type := 57; + N_Sar : constant Index_Type := 58; + + subtype S is String; + Names : constant Names_Type := + (N_None => new S'("none"), + N_Push => new S'("push"), + N_Pop => new S'("pop"), + N_Ret => new S'("ret"), + N_Mov => new S'("mov"), + N_Add => new S'("add"), + N_Or => new S'("or"), + N_Adc => new S'("adc"), + N_Sbb => new S'("sbb"), + N_And => new S'("and"), + N_Sub => new S'("sub"), + N_Xor => new S'("xor"), + N_Cmp => new S'("cmp"), + N_Into => new S'("into"), + N_Jmp => new S'("jmp"), + N_Jcc => new S'("j"), + N_Int => new S'("int"), + N_Cdq => new S'("cdq"), + N_Call => new S'("call"), + N_Imul => new S'("imul"), + N_Mul => new S'("mul"), + N_Leave => new S'("leave"), + N_Test => new S'("test"), + N_Setcc => new S'("set"), + N_Lea => new S'("lea"), + N_O => new S'("o"), + N_No => new S'("no"), + N_B => new S'("b"), + N_AE => new S'("ae"), + N_E => new S'("e"), + N_Ne => new S'("ne"), + N_Be => new S'("be"), + N_A => new S'("a"), + N_S => new S'("s"), + N_Ns => new S'("ns"), + N_P => new S'("p"), + N_Np => new S'("np"), + N_L => new S'("l"), + N_Ge => new S'("ge"), + N_Le => new S'("le"), + N_G => new S'("g"), + N_Not => new S'("not"), + N_Neg => new S'("neg"), + N_Cbw => new S'("cbw"), + N_Div => new S'("div"), + N_Idiv => new S'("idiv"), + N_Movsx => new S'("movsx"), + N_Movzx => new S'("movzx"), + N_Nop => new S'("nop"), + N_Hlt => new S'("hlt"), + N_Inc => new S'("inc"), + N_Dec => new S'("dec"), + N_Rol => new S'("rol"), + N_Ror => new S'("ror"), + N_Rcl => new S'("rcl"), + N_Rcr => new S'("rcr"), + N_Shl => new S'("shl"), + N_Shr => new S'("shr"), + N_Sar => new S'("sar") + ); + + + G_1 : constant Index_Type := 128; + G_2 : constant Index_Type := 129; + G_3 : constant Index_Type := 130; + G_5 : constant Index_Type := 131; + + -- Format of an instruction. + -- MODRM_SRC_8 : modrm byte follow, and modrm is source, witdh = 8bits + -- MODRM_DST_8 : modrm byte follow, and modrm is dest, width = 8 bits. + -- MODRM_SRC_W : modrm byte follow, and modrm is source, width = 16/32 bits + -- MODRM_DST_W : modrm byte follow, and modrm is dest, width =16/32 bits. + -- MODRM_IMM_W : modrm byte follow, with an opcode in the reg field, + -- followed by an immediat, width = 16/32 bits. + -- MODRM_IMM_8 : modrm byte follow, with an opcode in the reg field, + -- followed by an immediat, width = 8 bits. + -- IMM : the opcode is followed by an immediate value. + -- PREFIX : the opcode is a prefix (1 byte). + -- OPCODE : inherent addressing. + -- OPCODE2 : a second byte specify the instruction. + -- REG_IMP : register is in the 3 LSB of the opcode. + -- REG_IMM_W : register is in the 3 LSB of the opcode, followed by an + -- immediat, width = 16/32 bits. + -- DISP_W : a wide displacement (16/32 bits). + -- DISP_8 : short displacement (8 bits). + -- INVALID : bad opcode. + type Format_Type is (Modrm_Src, Modrm_Dst, + Modrm_Imm, Modrm_Imm_S, + Modrm, + Modrm_Ax, + Modrm_Imm8, + Imm, Imm_S, Imm_8, + Eax_Imm, + Prefix, Opcode, Opcode2, Reg_Imp, + Reg_Imm, + Imp, + Disp_W, Disp_8, + Cond_Disp_W, Cond_Disp_8, + Cond_Modrm, + Ax_Off_Src, Ax_Off_Dst, + Invalid); + + type Width_Type is (W_None, W_8, W_16, W_32, W_Data); + + -- Description for one instruction. + type Insn_Desc_Type is record + -- Name of the operation. + Name : Index_Type; + + -- Width of the instruction. + -- This is used to add a suffix (b,w,l) to the instruction. + -- This may also be the size of a data. + Width : Width_Type; + + -- Format of the instruction. + Format : Format_Type; + end record; + + Desc_Invalid : constant Insn_Desc_Type := (N_None, W_None, Invalid); + + type Insn_Desc_Array_Type is array (Byte) of Insn_Desc_Type; + type Group_Desc_Array_Type is array (Bf_3) of Insn_Desc_Type; + Insn_Desc : constant Insn_Desc_Array_Type := + ( + 2#00_000_000# => (N_Add, W_8, Modrm_Dst), + 2#00_000_001# => (N_Add, W_Data, Modrm_Dst), + 2#00_000_010# => (N_Add, W_8, Modrm_Src), + 2#00_000_011# => (N_Add, W_Data, Modrm_Src), + + 2#00_001_000# => (N_Or, W_8, Modrm_Dst), + 2#00_001_001# => (N_Or, W_Data, Modrm_Dst), + 2#00_001_010# => (N_Or, W_8, Modrm_Src), + 2#00_001_011# => (N_Or, W_Data, Modrm_Src), + + 2#00_011_000# => (N_Sbb, W_8, Modrm_Dst), + 2#00_011_001# => (N_Sbb, W_Data, Modrm_Dst), + 2#00_011_010# => (N_Sbb, W_8, Modrm_Src), + 2#00_011_011# => (N_Sbb, W_Data, Modrm_Src), + + 2#00_100_000# => (N_And, W_8, Modrm_Dst), + 2#00_100_001# => (N_And, W_Data, Modrm_Dst), + 2#00_100_010# => (N_And, W_8, Modrm_Src), + 2#00_100_011# => (N_And, W_Data, Modrm_Src), + + 2#00_101_000# => (N_Sub, W_8, Modrm_Dst), + 2#00_101_001# => (N_Sub, W_Data, Modrm_Dst), + 2#00_101_010# => (N_Sub, W_8, Modrm_Src), + 2#00_101_011# => (N_Sub, W_Data, Modrm_Src), + + 2#00_110_000# => (N_Xor, W_8, Modrm_Dst), + 2#00_110_001# => (N_Xor, W_Data, Modrm_Dst), + 2#00_110_010# => (N_Xor, W_8, Modrm_Src), + 2#00_110_011# => (N_Xor, W_Data, Modrm_Src), + + 2#00_111_000# => (N_Cmp, W_8, Modrm_Dst), + 2#00_111_001# => (N_Cmp, W_Data, Modrm_Dst), + 2#00_111_010# => (N_Cmp, W_8, Modrm_Src), + 2#00_111_011# => (N_Cmp, W_Data, Modrm_Src), + + 2#00_111_100# => (N_Cmp, W_8, Eax_Imm), + 2#00_111_101# => (N_Cmp, W_Data, Eax_Imm), + + 2#0101_0_000# => (N_Push, W_Data, Reg_Imp), + 2#0101_0_001# => (N_Push, W_Data, Reg_Imp), + 2#0101_0_010# => (N_Push, W_Data, Reg_Imp), + 2#0101_0_011# => (N_Push, W_Data, Reg_Imp), + 2#0101_0_100# => (N_Push, W_Data, Reg_Imp), + 2#0101_0_101# => (N_Push, W_Data, Reg_Imp), + 2#0101_0_110# => (N_Push, W_Data, Reg_Imp), + 2#0101_0_111# => (N_Push, W_Data, Reg_Imp), + + 2#0101_1_000# => (N_Pop, W_Data, Reg_Imp), + 2#0101_1_001# => (N_Pop, W_Data, Reg_Imp), + 2#0101_1_010# => (N_Pop, W_Data, Reg_Imp), + 2#0101_1_011# => (N_Pop, W_Data, Reg_Imp), + 2#0101_1_100# => (N_Pop, W_Data, Reg_Imp), + 2#0101_1_101# => (N_Pop, W_Data, Reg_Imp), + 2#0101_1_110# => (N_Pop, W_Data, Reg_Imp), + 2#0101_1_111# => (N_Pop, W_Data, Reg_Imp), + + 2#0110_1000# => (N_Push, W_Data, Imm), + 2#0110_1010# => (N_Push, W_Data, Imm_S), + + 2#0111_0000# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_0001# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_0010# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_0011# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_0100# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_0101# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_0110# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_0111# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_1000# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_1001# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_1010# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_1011# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_1100# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_1101# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_1110# => (N_Jcc, W_None, Cond_Disp_8), + 2#0111_1111# => (N_Jcc, W_None, Cond_Disp_8), + + 2#1000_0000# => (G_1, W_8, Modrm_Imm), + 2#1000_0001# => (G_1, W_Data, Modrm_Imm), + 2#1000_0011# => (G_1, W_Data, Modrm_Imm_S), + + 2#1000_0101# => (N_Test, W_Data, Modrm_Src), + 2#1000_1101# => (N_Lea, W_Data, Modrm_Src), + + 2#1000_1010# => (N_Mov, W_8, Modrm_Src), + 2#1000_1011# => (N_Mov, W_Data, Modrm_Src), + 2#1000_1000# => (N_Mov, W_8, Modrm_Dst), + 2#1000_1001# => (N_Mov, W_Data, Modrm_Dst), + + 2#1001_0000# => (N_Nop, W_None, Opcode), + 2#1001_1001# => (N_Cdq, W_Data, Imp), + + 2#1010_0000# => (N_Mov, W_8, Ax_Off_Src), + 2#1010_0001# => (N_Mov, W_Data, Ax_Off_Src), + 2#1010_0010# => (N_Mov, W_8, Ax_Off_Dst), + 2#1010_0011# => (N_Mov, W_Data, Ax_Off_Dst), + + 2#1011_0000# => (N_Mov, W_8, Reg_Imm), + + 2#1011_1000# => (N_Mov, W_Data, Reg_Imm), + 2#1011_1001# => (N_Mov, W_Data, Reg_Imm), + 2#1011_1010# => (N_Mov, W_Data, Reg_Imm), + 2#1011_1011# => (N_Mov, W_Data, Reg_Imm), + 2#1011_1100# => (N_Mov, W_Data, Reg_Imm), + 2#1011_1101# => (N_Mov, W_Data, Reg_Imm), + 2#1011_1110# => (N_Mov, W_Data, Reg_Imm), + 2#1011_1111# => (N_Mov, W_Data, Reg_Imm), + + 2#1100_0000# => (G_2, W_8, Modrm_Imm8), + 2#1100_0001# => (G_2, W_Data, Modrm_Imm8), + + 2#1100_0011# => (N_Ret, W_None, Opcode), + 2#1100_0110# => (N_Mov, W_8, Modrm_Imm), + 2#1100_0111# => (N_Mov, W_Data, Modrm_Imm), + 2#1100_1001# => (N_Leave, W_None, Opcode), + 2#1100_1101# => (N_Int, W_None, Imm_8), + 2#1100_1110# => (N_Into, W_None, Opcode), + + 2#1110_1000# => (N_Call, W_None, Disp_W), + 2#1110_1001# => (N_Jmp, W_None, Disp_W), + 2#1110_1011# => (N_Jmp, W_None, Disp_8), + + 2#1111_0100# => (N_Hlt, W_None, Opcode), + + 2#1111_0110# => (G_3, W_None, Invalid), + 2#1111_0111# => (G_3, W_None, Invalid), + + 2#1111_1111# => (G_5, W_None, Invalid), + --2#1111_1111# => (N_Push, W_Data, Modrm), + others => (N_None, W_None, Invalid)); + + Insn_Desc_0F : constant Insn_Desc_Array_Type := + (2#1000_0000# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_0001# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_0010# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_0011# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_0100# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_0101# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_0110# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_0111# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_1000# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_1001# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_1010# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_1011# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_1100# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_1101# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_1110# => (N_Jcc, W_None, Cond_Disp_W), + 2#1000_1111# => (N_Jcc, W_None, Cond_Disp_W), + + 2#1001_0000# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_0001# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_0010# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_0011# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_0100# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_0101# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_0110# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_0111# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_1000# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_1001# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_1010# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_1011# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_1100# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_1101# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_1110# => (N_Setcc, W_8, Cond_Modrm), + 2#1001_1111# => (N_Setcc, W_8, Cond_Modrm), + + 2#1011_0110# => (N_Movzx, W_Data, Modrm_Dst), + 2#1011_1110# => (N_Movsx, W_Data, Modrm_Dst), + others => (N_None, W_None, Invalid)); + + -- 16#F7# + Insn_Desc_G3 : constant Group_Desc_Array_Type := + (2#000# => (N_Test, W_Data, Reg_Imm), + 2#010# => (N_Not, W_Data, Modrm_Dst), + 2#011# => (N_Neg, W_Data, Modrm_Dst), + 2#100# => (N_Mul, W_Data, Modrm_Ax), + 2#101# => (N_Imul, W_Data, Modrm_Ax), + 2#110# => (N_Div, W_Data, Modrm_Ax), + 2#111# => (N_Idiv, W_Data, Modrm_Ax), + others => (N_None, W_None, Invalid)); + + Insn_Desc_G5 : constant Group_Desc_Array_Type := + (2#000# => (N_Inc, W_Data, Modrm), + 2#001# => (N_Dec, W_Data, Modrm), + 2#010# => (N_Call, W_Data, Modrm), + --2#011# => (N_Call, W_Data, Modrm_Ax), + 2#100# => (N_Jmp, W_Data, Modrm), + --2#101# => (N_Jmp, W_Data, Modrm_Ax), + 2#110# => (N_Push, W_Data, Modrm_Ax), + others => (N_None, W_None, Invalid)); + + type Group_Name_Array_Type is array (Index_Type range G_1 .. G_2, Bf_3) + of Index_Type; + Group_Name : constant Group_Name_Array_Type := + ( + G_1 => (N_Add, N_Or, N_Adc, N_Sbb, N_And, N_Sub, N_Xor, N_Cmp), + G_2 => (N_Rol, N_Ror, N_Rcl, N_Rcr, N_Shl, N_Shr, N_None, N_Sar) + ); + + -- Standard widths of operations. + type Width_Array_Type is array (Width_Type) of Character; + Width_Char : constant Width_Array_Type := + (W_None => '-', W_8 => 'b', W_16 => 'w', W_32 => 'l', W_Data => '?'); + type Width_Len_Type is array (Width_Type) of Natural; + Width_Len : constant Width_Len_Type := + (W_None => 0, W_8 => 1, W_16 => 2, W_32 => 4, W_Data => 0); + + -- Registers. +-- type Reg_Type is (Reg_Ax, Reg_Bx, Reg_Cx, Reg_Dx, +-- Reg_Bp, Reg_Sp, Reg_Si, Reg_Di, +-- Reg_Al, Reg_Ah, Reg_Bl, Reg_Bh, +-- Reg_Cl, Reg_Ch, Reg_Dl, Reg_Dh); + + -- Bits extraction from byte functions. + -- For a byte, MSB (most significant bit) is bit 7 while + -- LSB (least significant bit) is bit 0. + + -- Extract bits 2, 1 and 0. + function Ext_210 (B : Byte) return Bf_3; + pragma Inline (Ext_210); + + -- Extract bits 5-3 of byte B. + function Ext_543 (B : Byte) return Bf_3; + pragma Inline (Ext_543); + + -- Extract bits 7-6 of byte B. + function Ext_76 (B : Byte) return Bf_2; + pragma Inline (Ext_76); + + function Ext_210 (B : Byte) return Bf_3 is + begin + return Bf_3 (B and 2#111#); + end Ext_210; + + function Ext_543 (B : Byte) return Bf_3 is + begin + return Bf_3 (Shift_Right (B, 3) and 2#111#); + end Ext_543; + + function Ext_76 (B : Byte) return Bf_2 is + begin + return Bf_2 (Shift_Right (B, 6) and 2#11#); + end Ext_76; + + function Ext_Modrm_Mod (B : Byte) return Bf_2 renames Ext_76; + function Ext_Modrm_Rm (B : Byte) return Bf_3 renames Ext_210; + function Ext_Modrm_Reg (B : Byte) return Bf_3 renames Ext_543; + function Ext_Sib_Base (B : Byte) return Bf_3 renames Ext_210; + function Ext_Sib_Index (B : Byte) return Bf_3 renames Ext_543; + function Ext_Sib_Scale (B : Byte) return Bf_2 renames Ext_76; + + procedure Disassemble_Insn (Addr : System.Address; + Pc : Unsigned_32; + Line : in out String; + Line_Len : out Natural; + Insn_Len : out Natural; + Proc_Cb : Symbol_Proc_Type) + is + -- Index in LINE of the next character to be written. + Lo : Natural; + + -- Default width. + W_Default : constant Width_Type := W_32; + + -- The instruction memory, 0 based. + Mem : Bv_Addr2acc.Object_Pointer; + + -- Add NAME to the line. + procedure Add_Name (Name : Index_Type); + pragma Inline (Add_Name); + + -- Add CHAR to the line. + procedure Add_Char (C : Character); + pragma Inline (Add_Char); + + -- Add STR to the line. + procedure Add_String (Str : String) is + begin + Line (Lo .. Lo + Str'Length - 1) := Str; + Lo := Lo + Str'Length; + end Add_String; + + -- Add BYTE to the line. + procedure Add_Byte (V : Byte) is + type My_Str is array (Natural range 0 .. 15) of Character; + Hex_Digit : constant My_Str := "0123456789abcdef"; + begin + Add_Char (Hex_Digit (Natural (Shift_Right (V, 4) and 16#0f#))); + Add_Char (Hex_Digit (Natural (Shift_Right (V, 0) and 16#0f#))); + end Add_Byte; + + procedure Add_Name (Name : Index_Type) is + begin + Add_String (Names (Name).all); + end Add_Name; + + procedure Add_Char (C : Character) is + begin + Line (Lo) := C; + Lo := Lo + 1; + end Add_Char; + + procedure Add_Comma is + begin + Add_String (", "); + end Add_Comma; + + procedure Name_Align (Orig : Natural) is + begin + Add_Char (' '); + while Lo - Orig < 8 loop + Add_Char (' '); + end loop; + end Name_Align; + + procedure Add_Opcode (Name : Index_Type; Width : Width_Type) + is + L : constant Natural := Lo; + begin + Add_Name (Name); + if False and Width /= W_None then + Add_Char (Width_Char (Width)); + end if; + Name_Align (L); + end Add_Opcode; + + procedure Add_Cond_Opcode (Name : Index_Type; B : Byte) + is + L : constant Natural := Lo; + begin + Add_Name (Name); + Add_Name (N_O + Byte'Pos (B and 16#0f#)); + Name_Align (L); + end Add_Cond_Opcode; + + procedure Decode_Reg_Field (F : Bf_3; W : Width_Type) is + type Reg_Name2_Array is array (Bf_3) of String (1 .. 2); + type Reg_Name3_Array is array (Bf_3) of String (1 .. 3); + Regs_8 : constant Reg_Name2_Array := + ("al", "cl", "dl", "bl", "ah", "ch", "dh", "bh"); + Regs_16 : constant Reg_Name2_Array := + ("ax", "cx", "dx", "bx", "sp", "bp", "si", "di"); + Regs_32 : constant Reg_Name3_Array := + ("eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi"); + begin + Add_Char ('%'); + case W is + when W_8 => + Add_String (Regs_8 (F)); + when W_16 => + Add_String (Regs_16 (F)); + when W_32 => + Add_String (Regs_32 (F)); + when W_None + | W_Data => + raise Program_Error; + end case; + end Decode_Reg_Field; + + procedure Decode_Val (Off : Natural; Width : Width_Type) + is + begin + case Width is + when W_8 => + Add_Byte (Mem (Off)); + when W_16 => + Add_Byte (Mem (Off + 1)); + Add_Byte (Mem (Off)); + when W_32 => + Add_Byte (Mem (Off + 3)); + Add_Byte (Mem (Off + 2)); + Add_Byte (Mem (Off + 1)); + Add_Byte (Mem (Off + 0)); + when W_None + | W_Data => + raise Program_Error; + end case; + end Decode_Val; + + function Decode_Val (Off : Natural; Width : Width_Type) + return Unsigned_32 + is + V : Unsigned_32; + begin + case Width is + when W_8 => + V := Unsigned_32 (Mem (Off)); + -- Sign extension. + if V >= 16#80# then + V := 16#Ffff_Ff00# or V; + end if; + return V; + when W_16 => + return Shift_Left (Unsigned_32 (Mem (Off + 1)), 8) + or Unsigned_32 (Mem (Off)); + when W_32 => + return Shift_Left (Unsigned_32 (Mem (Off + 3)), 24) + or Shift_Left (Unsigned_32 (Mem (Off + 2)), 16) + or Shift_Left (Unsigned_32 (Mem (Off + 1)), 8) + or Shift_Left (Unsigned_32 (Mem (Off + 0)), 0); + when W_None + | W_Data => + raise Program_Error; + end case; + end Decode_Val; + + procedure Decode_Imm (Off : in out Natural; Width : Width_Type) + is + begin + Add_String ("$0x"); + Decode_Val (Off, Width); + Off := Off + Width_Len (Width); + end Decode_Imm; + + procedure Decode_Disp (Off : in out Natural; + Width : Width_Type; + Offset : Unsigned_32 := 0) + is + L : Natural; + V : Unsigned_32; + Off_Orig : constant Natural := Off; + begin + L := Lo; + V := Decode_Val (Off, Width) + Offset; + Off := Off + Width_Len (Width); + if Proc_Cb /= null then + Proc_Cb.all (Mem (Off)'Address, + Line (Lo .. Line'Last), Lo); + end if; + if L /= Lo then + if V = 0 then + return; + end if; + Add_String (" + "); + end if; + Add_String ("0x"); + if Offset = 0 then + Decode_Val (Off_Orig, Width); + else + Add_Byte (Byte (Shift_Right (V, 24) and 16#Ff#)); + Add_Byte (Byte (Shift_Right (V, 16) and 16#Ff#)); + Add_Byte (Byte (Shift_Right (V, 8) and 16#Ff#)); + Add_Byte (Byte (Shift_Right (V, 0) and 16#Ff#)); + end if; + end Decode_Disp; + + procedure Decode_Modrm_Reg (B : Byte; Width : Width_Type) is + begin + Decode_Reg_Field (Ext_Modrm_Reg (B), Width); + end Decode_Modrm_Reg; + + procedure Decode_Sib (Sib : Byte; B_Mod : Bf_2) + is + S : Bf_2; + I : Bf_3; + B : Bf_3; + begin + S := Ext_Sib_Scale (Sib); + B := Ext_Sib_Base (Sib); + I := Ext_Sib_Index (Sib); + Add_Char ('('); + if B = 2#101# and then B_Mod /= 0 then + Decode_Reg_Field (B, W_32); + Add_Char (','); + end if; + if I /= 2#100# then + Decode_Reg_Field (I, W_32); + case S is + when 2#00# => + null; + when 2#01# => + Add_String (",2"); + when 2#10# => + Add_String (",4"); + when 2#11# => + Add_String (",8"); + end case; + end if; + Add_Char (')'); + end Decode_Sib; + + procedure Decode_Modrm_Mem (Off : in out Natural; Width : Width_Type) + is + B : Byte; + B_Mod : Bf_2; + B_Rm : Bf_3; + Off_Orig : Natural; + begin + B := Mem (Off); + B_Mod := Ext_Modrm_Mod (B); + B_Rm := Ext_Modrm_Rm (B); + Off_Orig := Off; + case B_Mod is + when 2#11# => + Decode_Reg_Field (B_Rm, Width); + Off := Off + 1; + when 2#10# => + if B_Rm = 2#100# then + Off := Off + 2; + Decode_Disp (Off, W_32); + Decode_Sib (Mem (Off_Orig + 1), B_Mod); + else + Off := Off + 1; + Decode_Disp (Off, W_32); + Add_Char ('('); + Decode_Reg_Field (B_Rm, W_32); + Add_Char (')'); + end if; + when 2#01# => + if B_Rm = 2#100# then + Off := Off + 2; + Decode_Disp (Off, W_8); + Decode_Sib (Mem (Off_Orig + 1), B_Mod); + else + Off := Off + 1; + Decode_Disp (Off, W_8); + Add_Char ('('); + Decode_Reg_Field (B_Rm, W_32); + Add_Char (')'); + end if; + when 2#00# => + if B_Rm = 2#100# then + Off := Off + 2; + Decode_Sib (Mem (Off_Orig + 1), B_Mod); + elsif B_Rm = 2#101# then + Off := Off + 1; + Decode_Disp (Off, W_32); + else + Add_Char ('('); + Decode_Reg_Field (B_Rm, W_32); + Add_Char (')'); + Off := Off + 1; + end if; + end case; + end Decode_Modrm_Mem; + + -- Return the length of the modrm bytes. + -- At least 1 (mod/rm), at most 6 (mod/rm + SUB + disp32). + function Decode_Modrm_Len (Off : Natural) return Natural + is + B : Byte; + M_Mod : Bf_2; + M_Rm : Bf_3; + begin + B := Mem (Off); + M_Mod := Ext_Modrm_Mod (B); + M_Rm := Ext_Modrm_Rm (B); + case M_Mod is + when 2#11# => + return 1; + when 2#10# => + if M_Rm = 2#100# then + return 1 + 1 + 4; + else + return 1 + 4; + end if; + when 2#01# => + if M_Rm = 2#100# then + return 1 + 1 + 1; + else + return 1 + 1; + end if; + when 2#00# => + if M_Rm = 2#101# then + -- disp32. + return 1 + 4; + elsif M_Rm = 2#100# then + -- SIB + return 1 + 1; + else + return 1; + end if; + end case; + end Decode_Modrm_Len; + + + Off : Natural; + B : Byte; + B1 : Byte; + Desc : Insn_Desc_Type; + Name : Index_Type; + W : Width_Type; + begin + Mem := To_Pointer (Addr); + Off := 0; + Lo := Line'First; + + B := Mem (0); + if B = 2#0000_1111# then + B := Mem (1); + Off := 2; + Insn_Len := 2; + Desc := Insn_Desc_0F (B); + else + Off := 1; + Insn_Len := 1; + Desc := Insn_Desc (B); + end if; + + if Desc.Name >= G_1 then + B1 := Mem (Off); + case Desc.Name is + when G_1 + | G_2 => + Name := Group_Name (Desc.Name, Ext_543 (B1)); + when G_3 => + Desc := Insn_Desc_G3 (Ext_543 (B1)); + Name := Desc.Name; + when G_5 => + Desc := Insn_Desc_G5 (Ext_543 (B1)); + Name := Desc.Name; + when others => + Desc := Desc_Invalid; + end case; + else + Name := Desc.Name; + end if; + + case Desc.Width is + when W_Data => + W := W_Default; + when W_8 + | W_16 + | W_32 => + W := Desc.Width; + when W_None => + case Desc.Format is + when Disp_8 + | Cond_Disp_8 + | Imm_8 => + W := W_8; + when Disp_W + | Cond_Disp_W => + W := W_Default; + when Invalid + | Opcode => + W := W_None; + when others => + raise Program_Error; + end case; + end case; + + case Desc.Format is + when Reg_Imp => + Add_Opcode (Desc.Name, W_Default); + Decode_Reg_Field (Ext_210 (B), W_Default); + when Opcode => + Add_Opcode (Desc.Name, W_None); + when Modrm => + Add_Opcode (Desc.Name, W); + Decode_Modrm_Mem (Insn_Len, W); + when Modrm_Src => + Add_Opcode (Desc.Name, W); + -- Disp source first. + Decode_Modrm_Mem (Insn_Len, W); + Add_Comma; + B := Mem (Off); + Decode_Modrm_Reg (Mem (Off), W); + when Modrm_Dst => + Add_Opcode (Desc.Name, W); + -- Disp source first. + B := Mem (Off); + Decode_Modrm_Reg (B, W); + Add_Comma; + Decode_Modrm_Mem (Insn_Len, W); + when Modrm_Imm => + Add_Opcode (Name, W); + Insn_Len := Off + Decode_Modrm_Len (Off); + Decode_Imm (Insn_Len, W); + Add_Comma; + Decode_Modrm_Mem (Off, W); + when Modrm_Imm_S => + Add_Opcode (Name, W); + Insn_Len := Off + Decode_Modrm_Len (Off); + Decode_Imm (Insn_Len, W_8); + Add_Comma; + Decode_Modrm_Mem (Off, W); + when Modrm_Imm8 => + Add_Opcode (Name, W); + Decode_Modrm_Mem (Off, W); + Add_Comma; + Decode_Imm (Off, W_8); + + when Reg_Imm => + Add_Opcode (Desc.Name, W); + Decode_Imm (Insn_Len, W); + Add_Comma; + Decode_Reg_Field (Ext_210 (B), W); + when Eax_Imm => + Add_Opcode (Desc.Name, W); + Decode_Imm (Insn_Len, W); + Add_Comma; + Decode_Reg_Field (2#000#, W); + + when Disp_W + | Disp_8 => + Add_Opcode (Desc.Name, W_None); + Decode_Disp (Insn_Len, W, + Pc + Unsigned_32 (Insn_Len + Width_Len (W))); + + when Cond_Disp_8 + | Cond_Disp_W => + Add_Cond_Opcode (Desc.Name, B); + Decode_Disp (Insn_Len, W, + Pc + Unsigned_32 (Insn_Len + Width_Len (W))); + + when Cond_Modrm => + Add_Cond_Opcode (Desc.Name, B); + Decode_Modrm_Mem (Insn_Len, W); + + when Imm => + Add_Opcode (Desc.Name, W); + Decode_Imm (Insn_Len, W); + + when Imm_S + | Imm_8 => + Add_Opcode (Desc.Name, W); + Decode_Imm (Insn_Len, W_8); + + when Modrm_Ax => + if (B and 2#1#) = 2#0# then + W := W_8; + else + W := W_Default; + end if; + Add_Opcode (Desc.Name, W); + Decode_Reg_Field (0, W); + Add_Comma; + Decode_Modrm_Mem (Off, W); + + when Ax_Off_Src => + Add_Opcode (Desc.Name, W); + Decode_Disp (Insn_Len, W); + Add_Comma; + Decode_Reg_Field (0, W); + + when Ax_Off_Dst => + Add_Opcode (Desc.Name, W); + Decode_Reg_Field (0, W); + Add_Comma; + Decode_Disp (Insn_Len, W); + + when Imp => + Add_Opcode (Desc.Name, W_Default); + + when Invalid + | Prefix + | Opcode2 => + Add_String ("invalid "); + if Insn_Len = 2 then + Add_Byte (Mem (0)); + end if; + Add_Byte (B); + Insn_Len := 1; + end case; + + Line_Len := Lo - Line'First; + end Disassemble_Insn; +end Disa_X86; + + diff --git a/ortho/mcode/disa_x86.ads b/ortho/mcode/disa_x86.ads new file mode 100644 index 0000000..c215cf0 --- /dev/null +++ b/ortho/mcode/disa_x86.ads @@ -0,0 +1,34 @@ +-- X86 disassembler. +-- 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 System; +with Interfaces; use Interfaces; + +package Disa_X86 is + -- Call-back used to find a relocation symbol. + type Symbol_Proc_Type is access procedure (Addr : System.Address; + Line : in out String; + Line_Len : in out Natural); + + -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN. + procedure Disassemble_Insn (Addr : System.Address; + Pc : Unsigned_32; + Line : in out String; + Line_Len : out Natural; + Insn_Len : out Natural; + Proc_Cb : Symbol_Proc_Type); +end Disa_X86; diff --git a/ortho/mcode/disassemble.ads b/ortho/mcode/disassemble.ads new file mode 100644 index 0000000..5c9811f --- /dev/null +++ b/ortho/mcode/disassemble.ads @@ -0,0 +1,3 @@ +with Disa_X86; + +package Disassemble renames Disa_X86; diff --git a/ortho/mcode/dwarf.ads b/ortho/mcode/dwarf.ads new file mode 100644 index 0000000..40ee94f --- /dev/null +++ b/ortho/mcode/dwarf.ads @@ -0,0 +1,446 @@ +-- DWARF definitions. +-- 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 Interfaces; use Interfaces; + +package Dwarf is + DW_TAG_Array_Type : constant := 16#01#; + DW_TAG_Class_Type : constant := 16#02#; + DW_TAG_Entry_Point : constant := 16#03#; + DW_TAG_Enumeration_Type : constant := 16#04#; + DW_TAG_Formal_Parameter : constant := 16#05#; + DW_TAG_Imported_Declaration : constant := 16#08#; + DW_TAG_Label : constant := 16#0a#; + DW_TAG_Lexical_Block : constant := 16#0b#; + DW_TAG_Member : constant := 16#0d#; + DW_TAG_Pointer_Type : constant := 16#0f#; + DW_TAG_Reference_Type : constant := 16#10#; + DW_TAG_Compile_Unit : constant := 16#11#; + DW_TAG_String_Type : constant := 16#12#; + DW_TAG_Structure_Type : constant := 16#13#; + DW_TAG_Subroutine_Type : constant := 16#15#; + DW_TAG_Typedef : constant := 16#16#; + DW_TAG_Union_Type : constant := 16#17#; + DW_TAG_Unspecified_Parameters : constant := 16#18#; + DW_TAG_Variant : constant := 16#19#; + DW_TAG_Common_Block : constant := 16#1a#; + DW_TAG_Common_Inclusion : constant := 16#1b#; + DW_TAG_Inheritance : constant := 16#1c#; + DW_TAG_Inlined_Subroutine : constant := 16#1d#; + DW_TAG_Module : constant := 16#1e#; + DW_TAG_Ptr_To_Member_Type : constant := 16#1f#; + DW_TAG_Set_Type : constant := 16#20#; + DW_TAG_Subrange_Type : constant := 16#21#; + DW_TAG_With_Stmt : constant := 16#22#; + DW_TAG_Access_Declaration : constant := 16#23#; + DW_TAG_Base_Type : constant := 16#24#; + DW_TAG_Catch_Block : constant := 16#25#; + DW_TAG_Const_Type : constant := 16#26#; + DW_TAG_Constant : constant := 16#27#; + DW_TAG_Enumerator : constant := 16#28#; + DW_TAG_File_Type : constant := 16#29#; + DW_TAG_Friend : constant := 16#2a#; + DW_TAG_Namelist : constant := 16#2b#; + DW_TAG_Namelist_Item : constant := 16#2c#; + DW_TAG_Packed_Type : constant := 16#2d#; + DW_TAG_Subprogram : constant := 16#2e#; + DW_TAG_Template_Type_Parameter : constant := 16#2f#; + DW_TAG_Template_Value_Parameter : constant := 16#30#; + DW_TAG_Thrown_Type : constant := 16#31#; + DW_TAG_Try_Block : constant := 16#32#; + DW_TAG_Variant_Part : constant := 16#33#; + DW_TAG_Variable : constant := 16#34#; + DW_TAG_Volatile_Type : constant := 16#35#; + DW_TAG_Dwarf_Procedure : constant := 16#36#; + DW_TAG_Restrict_Type : constant := 16#37#; + DW_TAG_Interface_Type : constant := 16#38#; + DW_TAG_Namespace : constant := 16#39#; + DW_TAG_Imported_Module : constant := 16#3a#; + DW_TAG_Unspecified_Type : constant := 16#3b#; + DW_TAG_Partial_Unit : constant := 16#3c#; + DW_TAG_Imported_Unit : constant := 16#3d#; + DW_TAG_Mutable_Type : constant := 16#3e#; + DW_TAG_Lo_User : constant := 16#4080#; + DW_TAG_Hi_User : constant := 16#Ffff#; + + DW_CHILDREN_No : constant := 16#0#; + DW_CHILDREN_Yes : constant := 16#1#; + + DW_AT_Sibling : constant := 16#01#; -- reference + DW_AT_Location : constant := 16#02#; -- block, loclistptr + DW_AT_Name : constant := 16#03#; -- string + DW_AT_Ordering : constant := 16#09#; -- constant + DW_AT_Byte_Size : constant := 16#0b#; -- block, constant, ref + DW_AT_Bit_Offset : constant := 16#0c#; -- block, constant, ref + DW_AT_Bit_Size : constant := 16#0d#; -- block, constant, ref + DW_AT_Stmt_List : constant := 16#10#; -- lineptr + DW_AT_Low_Pc : constant := 16#11#; -- address + DW_AT_High_Pc : constant := 16#12#; -- address + DW_AT_Language : constant := 16#13#; -- constant + DW_AT_Discr : constant := 16#15#; -- reference + DW_AT_Discr_Value : constant := 16#16#; -- constant + DW_AT_Visibility : constant := 16#17#; -- constant + DW_AT_Import : constant := 16#18#; -- reference + DW_AT_String_Length : constant := 16#19#; -- block, loclistptr + DW_AT_Common_Reference : constant := 16#1a#; -- reference + DW_AT_Comp_Dir : constant := 16#1b#; -- string + DW_AT_Const_Value : constant := 16#1c#; -- block, constant, string + DW_AT_Containing_Type : constant := 16#1d#; -- reference + DW_AT_Default_Value : constant := 16#1e#; -- reference + DW_AT_Inline : constant := 16#20#; -- constant + DW_AT_Is_Optional : constant := 16#21#; -- flag + DW_AT_Lower_Bound : constant := 16#22#; -- block, constant, ref + DW_AT_Producer : constant := 16#25#; -- string + DW_AT_Prototyped : constant := 16#27#; -- flag + DW_AT_Return_Addr : constant := 16#2a#; -- block, loclistptr + DW_AT_Start_Scope : constant := 16#2c#; -- constant + DW_AT_Stride_Size : constant := 16#2e#; -- constant + DW_AT_Upper_Bound : constant := 16#2f#; -- block, constant, ref + DW_AT_Abstract_Origin : constant := 16#31#; -- reference + DW_AT_Accessibility : constant := 16#32#; -- constant + DW_AT_Address_Class : constant := 16#33#; -- constant + DW_AT_Artificial : constant := 16#34#; -- flag + DW_AT_Base_Types : constant := 16#35#; -- reference + DW_AT_Calling_Convention : constant := 16#36#; -- constant + DW_AT_Count : constant := 16#37#; -- block, constant, ref + DW_AT_Data_Member_Location : constant := 16#38#; -- block, const, loclistptr + DW_AT_Decl_Column : constant := 16#39#; -- constant + DW_AT_Decl_File : constant := 16#3a#; -- constant + DW_AT_Decl_Line : constant := 16#3b#; -- constant + DW_AT_Declaration : constant := 16#3c#; -- flag + DW_AT_Discr_List : constant := 16#3d#; -- block + DW_AT_Encoding : constant := 16#3e#; -- constant + DW_AT_External : constant := 16#3f#; -- flag + DW_AT_Frame_Base : constant := 16#40#; -- block, loclistptr + DW_AT_Friend : constant := 16#41#; -- reference + DW_AT_Identifier_Case : constant := 16#42#; -- constant + DW_AT_Macro_Info : constant := 16#43#; -- macptr + DW_AT_Namelist_Item : constant := 16#44#; -- block + DW_AT_Priority : constant := 16#45#; -- reference + DW_AT_Segment : constant := 16#46#; -- block, constant + DW_AT_Specification : constant := 16#47#; -- reference + DW_AT_Static_Link : constant := 16#48#; -- block, loclistptr + DW_AT_Type : constant := 16#49#; -- reference + DW_AT_Use_Location : constant := 16#4a#; -- block, loclistptr + DW_AT_Variable_Parameter : constant := 16#4b#; -- flag + DW_AT_Virtuality : constant := 16#4c#; -- constant + DW_AT_Vtable_Elem_Location : constant := 16#4d#; -- block, loclistptr + DW_AT_Allocated : constant := 16#4e#; -- block, constant, ref + DW_AT_Associated : constant := 16#4f#; -- block, constant, ref + DW_AT_Data_Location : constant := 16#50#; -- x50block + DW_AT_Stride : constant := 16#51#; -- block, constant, ref + DW_AT_Entry_Pc : constant := 16#52#; -- address + DW_AT_Use_UTF8 : constant := 16#53#; -- flag + DW_AT_Extension : constant := 16#04#; -- reference + DW_AT_Ranges : constant := 16#55#; -- rangelistptr + DW_AT_Trampoline : constant := 16#56#; -- address, flag, ref, str + DW_AT_Call_Column : constant := 16#57#; -- constant + DW_AT_Call_File : constant := 16#58#; -- constant + DW_AT_Call_Line : constant := 16#59#; -- constant + DW_AT_Description : constant := 16#5a#; -- string + DW_AT_Lo_User : constant := 16#2000#; -- --- + DW_AT_Hi_User : constant := 16#3fff#; -- --- + + DW_FORM_Addr : constant := 16#01#; -- address + DW_FORM_Block2 : constant := 16#03#; -- block + DW_FORM_Block4 : constant := 16#04#; -- block + DW_FORM_Data2 : constant := 16#05#; -- constant + DW_FORM_Data4 : constant := 16#06#; -- constant, lineptr, loclistptr... + DW_FORM_Data8 : constant := 16#07#; -- ... macptr, rangelistptr + DW_FORM_String : constant := 16#08#; -- string + DW_FORM_Block : constant := 16#09#; -- block + DW_FORM_Block1 : constant := 16#0a#; -- block + DW_FORM_Data1 : constant := 16#0b#; -- constant + DW_FORM_Flag : constant := 16#0c#; -- flag + DW_FORM_Sdata : constant := 16#0d#; -- constant + DW_FORM_Strp : constant := 16#0e#; -- string + DW_FORM_Udata : constant := 16#0f#; -- constant + DW_FORM_Ref_Addr : constant := 16#10#; -- reference + DW_FORM_Ref1 : constant := 16#11#; -- reference + DW_FORM_Ref2 : constant := 16#12#; -- reference + DW_FORM_Ref4 : constant := 16#13#; -- reference + DW_FORM_Ref8 : constant := 16#14#; -- reference + DW_FORM_Ref_Udata : constant := 16#15#; -- reference + DW_FORM_Indirect : constant := 16#16#; -- (see Section 7.5.3) + + + DW_OP_Addr : constant := 16#03#; -- 1 constant address (target spec) + DW_OP_Deref : constant := 16#06#; -- 0 + DW_OP_Const1u : constant := 16#08#; -- 1 1-byte constant + DW_OP_Const1s : constant := 16#09#; -- 1 1-byte constant + DW_OP_Const2u : constant := 16#0a#; -- 1 2-byte constant + DW_OP_Const2s : constant := 16#0b#; -- 1 2-byte constant + DW_OP_Const4u : constant := 16#0c#; -- 1 4-byte constant + DW_OP_Const4s : constant := 16#0d#; -- 1 4-byte constant + DW_OP_Const8u : constant := 16#0e#; -- 1 8-byte constant + DW_OP_Const8s : constant := 16#0f#; -- 1 8-byte constant + DW_OP_Constu : constant := 16#10#; -- 1 ULEB128 constant + DW_OP_Consts : constant := 16#11#; -- 1 SLEB128 constant + DW_OP_Dup : constant := 16#12#; -- 0 + DW_OP_Drop : constant := 16#13#; -- 0 + DW_OP_Over : constant := 16#14#; -- 0 + DW_OP_Pick : constant := 16#15#; -- 1 1-byte stack index + DW_OP_Swap : constant := 16#16#; -- 0 + DW_OP_Rot : constant := 16#17#; -- 0 + DW_OP_Xderef : constant := 16#18#; -- 0 + DW_OP_Abs : constant := 16#19#; -- 0 + DW_OP_And : constant := 16#1a#; -- 0 + DW_OP_Div : constant := 16#1b#; -- 0 + DW_OP_Minus : constant := 16#1c#; -- 0 + DW_OP_Mod : constant := 16#1d#; -- 0 + DW_OP_Mul : constant := 16#1e#; -- 0 + DW_OP_Neg : constant := 16#1f#; -- 0 + DW_OP_Not : constant := 16#20#; -- 0 + DW_OP_Or : constant := 16#21#; -- 0 + DW_OP_Plus : constant := 16#22#; -- 0 + DW_OP_Plus_Uconst : constant := 16#23#; -- 1 ULEB128 addend + DW_OP_Shl : constant := 16#24#; -- 0 + DW_OP_Shr : constant := 16#25#; -- 0 + DW_OP_Shra : constant := 16#26#; -- 0 + DW_OP_Xor : constant := 16#27#; -- 0 + DW_OP_Skip : constant := 16#2f#; -- 1 signed 2-byte constant + DW_OP_Bra : constant := 16#28#; -- 1 signed 2-byte constant + DW_OP_Eq : constant := 16#29#; -- 0 + DW_OP_Ge : constant := 16#2a#; -- 0 + DW_OP_Gt : constant := 16#2b#; -- 0 + DW_OP_Le : constant := 16#2c#; -- 0 + DW_OP_Lt : constant := 16#2d#; -- 0 + DW_OP_Ne : constant := 16#2e#; -- 0 + DW_OP_Lit0 : constant := 16#30#; -- 0 + DW_OP_Lit1 : constant := 16#31#; -- 0 + DW_OP_Lit2 : constant := 16#32#; -- 0 + DW_OP_Lit3 : constant := 16#33#; -- 0 + DW_OP_Lit4 : constant := 16#34#; -- 0 + DW_OP_Lit5 : constant := 16#35#; -- 0 + DW_OP_Lit6 : constant := 16#36#; -- 0 + DW_OP_Lit7 : constant := 16#37#; -- 0 + DW_OP_Lit8 : constant := 16#38#; -- 0 + DW_OP_Lit9 : constant := 16#39#; -- 0 + DW_OP_Lit10 : constant := 16#3a#; -- 0 + DW_OP_Lit11 : constant := 16#3b#; -- 0 + DW_OP_Lit12 : constant := 16#3c#; -- 0 + DW_OP_Lit13 : constant := 16#3d#; -- 0 + DW_OP_Lit14 : constant := 16#3e#; -- 0 + DW_OP_Lit15 : constant := 16#3f#; -- 0 + DW_OP_Lit16 : constant := 16#40#; -- 0 + DW_OP_Lit17 : constant := 16#41#; -- 0 + DW_OP_Lit18 : constant := 16#42#; -- 0 + DW_OP_Lit19 : constant := 16#43#; -- 0 + DW_OP_Lit20 : constant := 16#44#; -- 0 + DW_OP_Lit21 : constant := 16#45#; -- 0 + DW_OP_Lit22 : constant := 16#46#; -- 0 + DW_OP_Lit23 : constant := 16#47#; -- 0 + DW_OP_Lit24 : constant := 16#48#; -- 0 + DW_OP_Lit25 : constant := 16#49#; -- 0 + DW_OP_Lit26 : constant := 16#4a#; -- 0 + DW_OP_Lit27 : constant := 16#4b#; -- 0 + DW_OP_Lit28 : constant := 16#4c#; -- 0 + DW_OP_Lit29 : constant := 16#4d#; -- 0 + DW_OP_Lit30 : constant := 16#4e#; -- 0 + DW_OP_Lit31 : constant := 16#4f#; -- 0 + DW_OP_Reg0 : constant := 16#50#; -- 0 + DW_OP_Reg1 : constant := 16#51#; -- 0 + DW_OP_Reg2 : constant := 16#52#; -- 0 + DW_OP_Reg3 : constant := 16#53#; -- 0 + DW_OP_Reg4 : constant := 16#54#; -- 0 + DW_OP_Reg5 : constant := 16#55#; -- 0 + DW_OP_Reg6 : constant := 16#56#; -- 0 + DW_OP_Reg7 : constant := 16#57#; -- 0 + DW_OP_Reg8 : constant := 16#58#; -- 0 + DW_OP_Reg9 : constant := 16#59#; -- 0 + DW_OP_Reg10 : constant := 16#5a#; -- 0 + DW_OP_Reg11 : constant := 16#5b#; -- 0 + DW_OP_Reg12 : constant := 16#5c#; -- 0 + DW_OP_Reg13 : constant := 16#5d#; -- 0 + DW_OP_Reg14 : constant := 16#5e#; -- 0 + DW_OP_Reg15 : constant := 16#5f#; -- 0 + DW_OP_Reg16 : constant := 16#60#; -- 0 + DW_OP_Reg17 : constant := 16#61#; -- 0 + DW_OP_Reg18 : constant := 16#62#; -- 0 + DW_OP_Reg19 : constant := 16#63#; -- 0 + DW_OP_Reg20 : constant := 16#64#; -- 0 + DW_OP_Reg21 : constant := 16#65#; -- 0 + DW_OP_Reg22 : constant := 16#66#; -- 0 + DW_OP_Reg23 : constant := 16#67#; -- 0 + DW_OP_Reg24 : constant := 16#68#; -- 0 + DW_OP_Reg25 : constant := 16#69#; -- 0 + DW_OP_Reg26 : constant := 16#6a#; -- 0 + DW_OP_Reg27 : constant := 16#6b#; -- 0 + DW_OP_Reg28 : constant := 16#6c#; -- 0 + DW_OP_Reg29 : constant := 16#6d#; -- 0 + DW_OP_Reg30 : constant := 16#6e#; -- 0 + DW_OP_Reg31 : constant := 16#6f#; -- 0 reg 0..31 + DW_OP_Breg0 : constant := 16#70#; -- 1 SLEB128 offset base reg + DW_OP_Breg1 : constant := 16#71#; -- 1 SLEB128 offset base reg + DW_OP_Breg2 : constant := 16#72#; -- 1 SLEB128 offset base reg + DW_OP_Breg3 : constant := 16#73#; -- 1 SLEB128 offset base reg + DW_OP_Breg4 : constant := 16#74#; -- 1 SLEB128 offset base reg + DW_OP_Breg5 : constant := 16#75#; -- 1 SLEB128 offset base reg + DW_OP_Breg6 : constant := 16#76#; -- 1 SLEB128 offset base reg + DW_OP_Breg7 : constant := 16#77#; -- 1 SLEB128 offset base reg + DW_OP_Breg8 : constant := 16#78#; -- 1 SLEB128 offset base reg + DW_OP_Breg9 : constant := 16#79#; -- 1 SLEB128 offset base reg + DW_OP_Breg10 : constant := 16#7a#; -- 1 SLEB128 offset base reg + DW_OP_Breg11 : constant := 16#7b#; -- 1 SLEB128 offset base reg + DW_OP_Breg12 : constant := 16#7c#; -- 1 SLEB128 offset base reg + DW_OP_Breg13 : constant := 16#7d#; -- 1 SLEB128 offset base reg + DW_OP_Breg14 : constant := 16#7e#; -- 1 SLEB128 offset base reg + DW_OP_Breg15 : constant := 16#7f#; -- 1 SLEB128 offset base reg + DW_OP_Breg16 : constant := 16#80#; -- 1 SLEB128 offset base reg + DW_OP_Breg17 : constant := 16#81#; -- 1 SLEB128 offset base reg + DW_OP_Breg18 : constant := 16#82#; -- 1 SLEB128 offset base reg + DW_OP_Breg19 : constant := 16#83#; -- 1 SLEB128 offset base reg + DW_OP_Breg20 : constant := 16#84#; -- 1 SLEB128 offset base reg + DW_OP_Breg21 : constant := 16#85#; -- 1 SLEB128 offset base reg + DW_OP_Breg22 : constant := 16#86#; -- 1 SLEB128 offset base reg + DW_OP_Breg23 : constant := 16#87#; -- 1 SLEB128 offset base reg + DW_OP_Breg24 : constant := 16#88#; -- 1 SLEB128 offset base reg + DW_OP_Breg25 : constant := 16#89#; -- 1 SLEB128 offset base reg + DW_OP_Breg26 : constant := 16#8a#; -- 1 SLEB128 offset base reg + DW_OP_Breg27 : constant := 16#8b#; -- 1 SLEB128 offset base reg + DW_OP_Breg28 : constant := 16#8c#; -- 1 SLEB128 offset base reg + DW_OP_Breg29 : constant := 16#8d#; -- 1 SLEB128 offset base reg + DW_OP_Breg30 : constant := 16#8e#; -- 1 SLEB128 offset base reg + DW_OP_Breg31 : constant := 16#8f#; -- 1 SLEB128 offset base reg 0..31 + DW_OP_Regx : constant := 16#90#; -- 1 ULEB128 register + DW_OP_Fbreg : constant := 16#91#; -- 1 SLEB128 offset + DW_OP_Bregx : constant := 16#92#; -- 2 ULEB128 reg + SLEB128 offset + DW_OP_Piece : constant := 16#93#; -- 1 ULEB128 size of piece addressed + DW_OP_Deref_Size : constant := 16#94#; -- 1 1-byte size of data retrieved + DW_OP_Xderef_Size : constant := 16#95#; -- 1 1-byte size of data retrieved + DW_OP_Nop : constant := 16#96#; -- 0 + DW_OP_Push_Object_Address : constant := 16#97#; -- 0 + DW_OP_Call2 : constant := 16#98#; -- 1 2-byte offset of DIE + DW_OP_Call4 : constant := 16#99#; -- 1 4-byte offset of DIE + DW_OP_Call_Ref : constant := 16#9a#; -- 1 4- or 8-byte offset of DIE + DW_OP_Lo_User : constant := 16#E0#; -- + DW_OP_Hi_User : constant := 16#ff#; -- + + DW_ATE_Address : constant := 16#1#; + DW_ATE_Boolean : constant := 16#2#; + DW_ATE_Complex_Float : constant := 16#3#; + DW_ATE_Float : constant := 16#4#; + DW_ATE_Signed : constant := 16#5#; + DW_ATE_Signed_Char : constant := 16#6#; + DW_ATE_Unsigned : constant := 16#7#; + DW_ATE_Unsigned_Char : constant := 16#8#; + DW_ATE_Imaginary_Float : constant := 16#9#; + DW_ATE_Lo_User : constant := 16#80#; + DW_ATE_Hi_User : constant := 16#ff#; + + DW_ACCESS_Public : constant := 1; + DW_ACCESS_Protected : constant := 2; + DW_ACCESS_Private : constant := 3; + + DW_LANG_C89 : constant := 16#0001#; + DW_LANG_C : constant := 16#0002#; + DW_LANG_Ada83 : constant := 16#0003#; + DW_LANG_C_Plus_Plus : constant := 16#0004#; + DW_LANG_Cobol74 : constant := 16#0005#; + DW_LANG_Cobol85 : constant := 16#0006#; + DW_LANG_Fortran77 : constant := 16#0007#; + DW_LANG_Fortran90 : constant := 16#0008#; + DW_LANG_Pascal83 : constant := 16#0009#; + DW_LANG_Modula2 : constant := 16#000a#; + DW_LANG_Java : constant := 16#000b#; + DW_LANG_C99 : constant := 16#000c#; + DW_LANG_Ada95 : constant := 16#000d#; + DW_LANG_Fortran95 : constant := 16#000e#; + DW_LANG_PLI : constant := 16#000f#; + DW_LANG_Lo_User : constant := 16#8000#; + DW_LANG_Hi_User : constant := 16#ffff#; + + DW_ID_Case_Sensitive : constant := 0; + DW_ID_Up_Case : constant := 1; + DW_ID_Down_Case : constant := 2; + DW_ID_Case_Insensitive : constant := 3; + + DW_CC_Normal : constant := 16#1#; + DW_CC_Program : constant := 16#2#; + DW_CC_Nocall : constant := 16#3#; + DW_CC_Lo_User : constant := 16#40#; + DW_CC_Hi_User : constant := 16#Ff#; + + DW_INL_Not_Inlined : constant := 0; + DW_INL_Inlined : constant := 1; + DW_INL_Declared_Not_Inlined : constant := 2; + DW_INL_Declared_Inlined : constant := 3; + + -- Line number information. + -- Line number standard opcode. + DW_LNS_Copy : constant Unsigned_8 := 1; + DW_LNS_Advance_Pc : constant Unsigned_8 := 2; + DW_LNS_Advance_Line : constant Unsigned_8 := 3; + DW_LNS_Set_File : constant Unsigned_8 := 4; + DW_LNS_Set_Column : constant Unsigned_8 := 5; + DW_LNS_Negate_Stmt : constant Unsigned_8 := 6; + DW_LNS_Set_Basic_Block : constant Unsigned_8 := 7; + DW_LNS_Const_Add_Pc : constant Unsigned_8 := 8; + DW_LNS_Fixed_Advance_Pc : constant Unsigned_8 := 9; + DW_LNS_Set_Prologue_End : constant Unsigned_8 := 10; + DW_LNS_Set_Epilogue_Begin : constant Unsigned_8 := 11; + DW_LNS_Set_Isa : constant Unsigned_8 := 12; + + -- Line number extended opcode. + DW_LNE_End_Sequence : constant Unsigned_8 := 1; + DW_LNE_Set_Address : constant Unsigned_8 := 2; + DW_LNE_Define_File : constant Unsigned_8 := 3; + DW_LNE_Lo_User : constant Unsigned_8 := 128; + DW_LNE_Hi_User : constant Unsigned_8 := 255; + + DW_CFA_Advance_Loc : constant Unsigned_8 := 16#40#; + DW_CFA_Advance_Loc_Min : constant Unsigned_8 := 16#40#; + DW_CFA_Advance_Loc_Max : constant Unsigned_8 := 16#7f#; + DW_CFA_Offset : constant Unsigned_8 := 16#80#; + DW_CFA_Offset_Min : constant Unsigned_8 := 16#80#; + DW_CFA_Offset_Max : constant Unsigned_8 := 16#Bf#; + DW_CFA_Restore : constant Unsigned_8 := 16#C0#; + DW_CFA_Restore_Min : constant Unsigned_8 := 16#C0#; + DW_CFA_Restore_Max : constant Unsigned_8 := 16#FF#; + DW_CFA_Nop : constant Unsigned_8 := 16#00#; + DW_CFA_Set_Loc : constant Unsigned_8 := 16#01#; + DW_CFA_Advance_Loc1 : constant Unsigned_8 := 16#02#; + DW_CFA_Advance_Loc2 : constant Unsigned_8 := 16#03#; + DW_CFA_Advance_Loc4 : constant Unsigned_8 := 16#04#; + DW_CFA_Offset_Extended : constant Unsigned_8 := 16#05#; + DW_CFA_Restore_Extended : constant Unsigned_8 := 16#06#; + DW_CFA_Undefined : constant Unsigned_8 := 16#07#; + DW_CFA_Same_Value : constant Unsigned_8 := 16#08#; + DW_CFA_Register : constant Unsigned_8 := 16#09#; + DW_CFA_Remember_State : constant Unsigned_8 := 16#0a#; + DW_CFA_Restore_State : constant Unsigned_8 := 16#0b#; + DW_CFA_Def_Cfa : constant Unsigned_8 := 16#0c#; + DW_CFA_Def_Cfa_Register : constant Unsigned_8 := 16#0d#; + DW_CFA_Def_Cfa_Offset : constant Unsigned_8 := 16#0e#; + DW_CFA_Def_Cfa_Expression : constant Unsigned_8 := 16#0f#; + + DW_EH_PE_Omit : constant Unsigned_8 := 16#Ff#; + DW_EH_PE_Uleb128 : constant Unsigned_8 := 16#01#; + DW_EH_PE_Udata2 : constant Unsigned_8 := 16#02#; + DW_EH_PE_Udata4 : constant Unsigned_8 := 16#03#; + DW_EH_PE_Udata8 : constant Unsigned_8 := 16#04#; + DW_EH_PE_Sleb128 : constant Unsigned_8 := 16#09#; + DW_EH_PE_Sdata2 : constant Unsigned_8 := 16#0A#; + DW_EH_PE_Sdata4 : constant Unsigned_8 := 16#0B#; + DW_EH_PE_Sdata8 : constant Unsigned_8 := 16#0C#; + DW_EH_PE_Absptr : constant Unsigned_8 := 16#00#; + DW_EH_PE_Pcrel : constant Unsigned_8 := 16#10#; + DW_EH_PE_Datarel : constant Unsigned_8 := 16#30#; + DW_EH_PE_Format_Mask : constant Unsigned_8 := 16#0f#; +end Dwarf; + + diff --git a/ortho/mcode/elf32.adb b/ortho/mcode/elf32.adb new file mode 100644 index 0000000..ef58fe6 --- /dev/null +++ b/ortho/mcode/elf32.adb @@ -0,0 +1,48 @@ +-- ELF32 definitions. +-- 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. +package body Elf32 is + function Elf32_St_Bind (Info : Elf32_Uchar) return Elf32_Uchar is + begin + return Shift_Right (Info, 4); + end Elf32_St_Bind; + + function Elf32_St_Type (Info : Elf32_Uchar) return Elf32_Uchar is + begin + return Info and 16#0F#; + end Elf32_St_Type; + + function Elf32_St_Info (B, T : Elf32_Uchar) return Elf32_Uchar is + begin + return Shift_Left (B, 4) or T; + end Elf32_St_Info; + + function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word is + begin + return Shift_Right (I, 8); + end Elf32_R_Sym; + + function Elf32_R_Type (I : Elf32_Word) return Elf32_Word is + begin + return I and 16#Ff#; + end Elf32_R_Type; + + function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word is + begin + return Shift_Left (S, 8) or T; + end Elf32_R_Info; +end Elf32; diff --git a/ortho/mcode/elf32.ads b/ortho/mcode/elf32.ads new file mode 100644 index 0000000..5afd317 --- /dev/null +++ b/ortho/mcode/elf32.ads @@ -0,0 +1,124 @@ +-- ELF32 definitions. +-- 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 Interfaces; use Interfaces; +with System; +with Elf_Common; use Elf_Common; + +package Elf32 is + subtype Elf32_Addr is Unsigned_32; + subtype Elf32_Half is Unsigned_16; + subtype Elf32_Off is Unsigned_32; + subtype Elf32_Sword is Integer_32; + subtype Elf32_Word is Unsigned_32; + subtype Elf32_Uchar is Unsigned_8; + + type Elf32_Ehdr is record + E_Ident : E_Ident_Type; + E_Type : Elf32_Half; + E_Machine : Elf32_Half; + E_Version : Elf32_Word; + E_Entry : Elf32_Addr; + E_Phoff : Elf32_Off; + E_Shoff : Elf32_Off; + E_Flags : Elf32_Word; + E_Ehsize : Elf32_Half; + E_Phentsize : Elf32_Half; + E_Phnum : Elf32_Half; + E_Shentsize : Elf32_Half; + E_Shnum : Elf32_Half; + E_Shstrndx : Elf32_Half; + end record; + + Elf32_Ehdr_Size : constant Natural := Elf32_Ehdr'Size / System.Storage_Unit; + + type Elf32_Shdr is record + Sh_Name : Elf32_Word; + Sh_Type : Elf32_Word; + Sh_Flags : Elf32_Word; + Sh_Addr : Elf32_Addr; + Sh_Offset : Elf32_Off; + Sh_Size : Elf32_Word; + Sh_Link : Elf32_Word; + Sh_Info : Elf32_Word; + Sh_Addralign : Elf32_Word; + Sh_Entsize : Elf32_Word; + end record; + Elf32_Shdr_Size : constant Natural := Elf32_Shdr'Size / System.Storage_Unit; + + -- Symbol table. + type Elf32_Sym is record + St_Name : Elf32_Word; + St_Value : Elf32_Addr; + St_Size : Elf32_Word; + St_Info : Elf32_Uchar; + St_Other : Elf32_Uchar; + St_Shndx : Elf32_Half; + end record; + Elf32_Sym_Size : constant Natural := Elf32_Sym'Size / System.Storage_Unit; + + function Elf32_St_Bind (Info : Elf32_Uchar) return Elf32_Uchar; + function Elf32_St_Type (Info : Elf32_Uchar) return Elf32_Uchar; + function Elf32_St_Info (B, T : Elf32_Uchar) return Elf32_Uchar; + pragma Inline (Elf32_St_Bind); + pragma Inline (Elf32_St_Type); + pragma Inline (Elf32_St_Info); + + -- Relocation. + type Elf32_Rel is record + R_Offset : Elf32_Addr; + R_Info : Elf32_Word; + end record; + Elf32_Rel_Size : constant Natural := Elf32_Rel'Size / System.Storage_Unit; + + type Elf32_Rela is record + R_Offset : Elf32_Addr; + R_Info : Elf32_Word; + R_Addend : Elf32_Sword; + end record; + Elf32_Rela_Size : constant Natural := Elf32_Rela'Size / System.Storage_Unit; + + function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word; + function Elf32_R_Type (I : Elf32_Word) return Elf32_Word; + function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word; + + -- For i386 + R_386_NONE : constant Elf32_Word := 0; -- none none + R_386_32 : constant Elf32_Word := 1; -- word32 S+A + R_386_PC32 : constant Elf32_Word := 2; -- word32 S+A-P + + -- For sparc + R_SPARC_NONE : constant Elf32_Word := 0; -- none + R_SPARC_32 : constant Elf32_Word := 3; -- (S + A) + R_SPARC_WDISP30 : constant Elf32_Word := 7; -- (S + A - P) >> 2 + R_SPARC_WDISP22 : constant Elf32_Word := 8; -- (S + A - P) >> 2 + R_SPARC_HI22 : constant Elf32_Word := 9; -- (S + A) >> 10 + R_SPARC_LO10 : constant Elf32_Word := 12; -- (S + A) & 0x3ff + R_SPARC_UA32 : constant Elf32_Word := 23; -- (S + A) + + type Elf32_Phdr is record + P_Type : Elf32_Word; + P_Offset : Elf32_Off; + P_Vaddr : Elf32_Addr; + P_Paddr : Elf32_Addr; + P_Filesz : Elf32_Word; + P_Memsz : Elf32_Word; + P_Flags : Elf32_Word; + P_Align : Elf32_Word; + end record; + Elf32_Phdr_Size : constant Natural := Elf32_Phdr'Size / System.Storage_Unit; +end Elf32; diff --git a/ortho/mcode/elf64.ads b/ortho/mcode/elf64.ads new file mode 100644 index 0000000..217e555 --- /dev/null +++ b/ortho/mcode/elf64.ads @@ -0,0 +1,105 @@ +-- ELF64 definitions. +-- 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 Interfaces; use Interfaces; +with System; +with Elf_Common; use Elf_Common; + +package Elf64 is + subtype Elf64_Addr is Unsigned_64; + subtype Elf64_Off is Unsigned_64; + subtype Elf64_Uchar is Unsigned_8; + subtype Elf64_Half is Unsigned_16; + subtype Elf64_Sword is Integer_32; + subtype Elf64_Word is Unsigned_32; + subtype Elf64_Xword is Unsigned_64; + subtype Elf64_Sxword is Integer_64; + + type Elf64_Ehdr is record + E_Ident : E_Ident_Type; + E_Type : Elf64_Half; + E_Machine : Elf64_Half; + E_Version : Elf64_Word; + E_Entry : Elf64_Addr; + E_Phoff : Elf64_Off; + E_Shoff : Elf64_Off; + E_Flags : Elf64_Word; + E_Ehsize : Elf64_Half; + E_Phentsize : Elf64_Half; + E_Phnum : Elf64_Half; + E_Shentsize : Elf64_Half; + E_Shnum : Elf64_Half; + E_Shstrndx : Elf64_Half; + end record; + + Elf64_Ehdr_Size : constant Natural := Elf64_Ehdr'Size / System.Storage_Unit; + + type Elf64_Shdr is record + Sh_Name : Elf64_Word; + Sh_Type : Elf64_Word; + Sh_Flags : Elf64_Xword; + Sh_Addr : Elf64_Addr; + Sh_Offset : Elf64_Off; + Sh_Size : Elf64_Xword; + Sh_Link : Elf64_Word; + Sh_Info : Elf64_Word; + Sh_Addralign : Elf64_Xword; + Sh_Entsize : Elf64_Xword; + end record; + Elf64_Shdr_Size : constant Natural := Elf64_Shdr'Size / System.Storage_Unit; + + -- Symbol table. + type Elf64_Sym is record + St_Name : Elf64_Word; + St_Info : Elf64_Uchar; + St_Other : Elf64_Uchar; + St_Shndx : Elf64_Half; + St_Value : Elf64_Addr; + St_Size : Elf64_Xword; + end record; + Elf64_Sym_Size : constant Natural := Elf64_Sym'Size / System.Storage_Unit; + + -- Relocation. + type Elf64_Rel is record + R_Offset : Elf64_Addr; + R_Info : Elf64_Xword; + end record; + Elf64_Rel_Size : constant Natural := Elf64_Rel'Size / System.Storage_Unit; + + type Elf64_Rela is record + R_Offset : Elf64_Addr; + R_Info : Elf64_Xword; + R_Addend : Elf64_Sxword; + end record; + Elf64_Rela_Size : constant Natural := Elf64_Rela'Size / System.Storage_Unit; + +-- function Elf64_R_Sym (I : Elf64_Word) return Elf64_Word; +-- function Elf64_R_Type (I : Elf64_Word) return Elf64_Word; +-- function Elf64_R_Info (S, T : Elf64_Word) return Elf64_Word; + + type Elf64_Phdr is record + P_Type : Elf64_Word; + P_Flags : Elf64_Word; + P_Offset : Elf64_Off; + P_Vaddr : Elf64_Addr; + P_Paddr : Elf64_Addr; + P_Filesz : Elf64_Xword; + P_Memsz : Elf64_Xword; + P_Align : Elf64_Xword; + end record; + Elf64_Phdr_Size : constant Natural := Elf64_Phdr'Size / System.Storage_Unit; +end Elf64; diff --git a/ortho/mcode/elf_arch.ads b/ortho/mcode/elf_arch.ads new file mode 100644 index 0000000..325c4e5 --- /dev/null +++ b/ortho/mcode/elf_arch.ads @@ -0,0 +1,2 @@ +with Elf_Arch32; +package Elf_Arch renames Elf_Arch32; diff --git a/ortho/mcode/elf_arch32.ads b/ortho/mcode/elf_arch32.ads new file mode 100644 index 0000000..5e987b1 --- /dev/null +++ b/ortho/mcode/elf_arch32.ads @@ -0,0 +1,37 @@ +-- ELF32 view of ELF. +-- 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 Elf_Common; use Elf_Common; +with Elf32; use Elf32; + +package Elf_Arch32 is + subtype Elf_Ehdr is Elf32_Ehdr; + subtype Elf_Shdr is Elf32_Shdr; + subtype Elf_Sym is Elf32_Sym; + subtype Elf_Rel is Elf32_Rel; + subtype Elf_Rela is Elf32_Rela; + subtype Elf_Phdr is Elf32_Phdr; + + subtype Elf_Off is Elf32_Off; + subtype Elf_Size is Elf32_Word; + Elf_Ehdr_Size : constant Natural := Elf32_Ehdr_Size; + Elf_Shdr_Size : constant Natural := Elf32_Shdr_Size; + Elf_Phdr_Size : constant Natural := Elf32_Phdr_Size; + Elf_Sym_Size : constant Natural := Elf32_Sym_Size; + + Elf_Arch_Class : constant Elf_Uchar := ELFCLASS32; +end Elf_Arch32; diff --git a/ortho/mcode/elf_arch64.ads b/ortho/mcode/elf_arch64.ads new file mode 100644 index 0000000..504cd66 --- /dev/null +++ b/ortho/mcode/elf_arch64.ads @@ -0,0 +1,37 @@ +-- ELF64 view of ELF. +-- 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 Elf_Common; use Elf_Common; +with Elf64; use Elf64; + +package Elf_Arch64 is + subtype Elf_Ehdr is Elf64_Ehdr; + subtype Elf_Shdr is Elf64_Shdr; + subtype Elf_Sym is Elf64_Sym; + subtype Elf_Rel is Elf64_Rel; + subtype Elf_Rela is Elf64_Rela; + subtype Elf_Phdr is Elf64_Phdr; + + subtype Elf_Off is Elf64_Off; + subtype Elf_Size is Elf64_Xword; + Elf_Ehdr_Size : constant Natural := Elf64_Ehdr_Size; + Elf_Shdr_Size : constant Natural := Elf64_Shdr_Size; + Elf_Phdr_Size : constant Natural := Elf64_Phdr_Size; + Elf_Sym_Size : constant Natural := Elf64_Sym_Size; + + Elf_Arch_Class : constant Elf_Uchar := ELFCLASS64; +end Elf_Arch64; diff --git a/ortho/mcode/elf_common.adb b/ortho/mcode/elf_common.adb new file mode 100644 index 0000000..5d05a2d --- /dev/null +++ b/ortho/mcode/elf_common.adb @@ -0,0 +1,48 @@ +-- ELF definitions. +-- 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. +package body Elf_Common is + function Elf_St_Bind (Info : Elf_Uchar) return Elf_Uchar is + begin + return Shift_Right (Info, 4); + end Elf_St_Bind; + + function Elf_St_Type (Info : Elf_Uchar) return Elf_Uchar is + begin + return Info and 16#0F#; + end Elf_St_Type; + + function Elf_St_Info (B, T : Elf_Uchar) return Elf_Uchar is + begin + return Shift_Left (B, 4) or T; + end Elf_St_Info; + +-- function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word is +-- begin +-- return Shift_Right (I, 8); +-- end Elf32_R_Sym; + +-- function Elf32_R_Type (I : Elf32_Word) return Elf32_Word is +-- begin +-- return I and 16#Ff#; +-- end Elf32_R_Type; + +-- function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word is +-- begin +-- return Shift_Left (S, 8) or T; +-- end Elf32_R_Info; +end Elf_Common; diff --git a/ortho/mcode/elf_common.ads b/ortho/mcode/elf_common.ads new file mode 100644 index 0000000..c53cd48 --- /dev/null +++ b/ortho/mcode/elf_common.ads @@ -0,0 +1,251 @@ +-- ELF definitions. +-- 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 Interfaces; use Interfaces; +with System; + +package Elf_Common is + subtype Elf_Half is Unsigned_16; + subtype Elf_Sword is Integer_32; + subtype Elf_Word is Unsigned_32; + subtype Elf_Uchar is Unsigned_8; + + EI_NIDENT : constant Natural := 16; + type E_Ident_Type is array (Natural range 0 .. EI_NIDENT - 1) + of Elf_Uchar; + + -- e_type values. + ET_NONE : constant Elf_Half := 0; -- No file type + ET_REL : constant Elf_Half := 1; -- Relocatable file + ET_EXEC : constant Elf_Half := 2; -- Executable file + ET_DYN : constant Elf_Half := 3; -- Shared object file + ET_CORE : constant Elf_Half := 4; -- Core file + ET_LOPROC : constant Elf_Half := 16#Ff00#; -- Processor-specific + ET_HIPROC : constant Elf_Half := 16#Ffff#; -- Processor-specific + + -- e_machine values. + EM_NONE : constant Elf_Half := 0; -- No machine + EM_M32 : constant Elf_Half := 1; -- AT&T WE 32100 + EM_SPARC : constant Elf_Half := 2; -- SPARC + EM_386 : constant Elf_Half := 3; -- Intel Architecture + EM_68K : constant Elf_Half := 4; -- Motorola 68000 + EM_88K : constant Elf_Half := 5; -- Motorola 88000 + EM_860 : constant Elf_Half := 7; -- Intel 80860 + EM_MIPS : constant Elf_Half := 8; -- MIPS RS3000 Big-Endian + EM_MIPS_RS4_BE : constant Elf_Half := 10; -- MIPS RS4000 Big-Endian + -- RESERVED : constant Elf_Half := 11; -- -16 Reserved for future use + + -- e_version + EV_NONE : constant Elf_Uchar := 0; -- Invalid versionn + EV_CURRENT : constant Elf_Uchar := 1; -- Current version + + -- e_ident identification indexes. + EI_MAG0 : constant Natural := 0; -- File identification + EI_MAG1 : constant Natural := 1; -- File identification + EI_MAG2 : constant Natural := 2; -- File identification + EI_MAG3 : constant Natural := 3; -- File identification + EI_CLASS : constant Natural := 4; -- File class + EI_DATA : constant Natural := 5; -- Data encoding + EI_VERSION : constant Natural := 6; -- File version + EI_PAD : constant Natural := 7; -- Start of padding bytes + --EI_NIDENT : constant Natural := 16; -- Size of e_ident[] + + -- Magic values. + ELFMAG0 : constant Elf_Uchar := 16#7f#; -- e_ident[EI_MAG0] + ELFMAG1 : constant Elf_Uchar := Character'Pos ('E'); -- e_ident[EI_MAG1] + ELFMAG2 : constant Elf_Uchar := Character'Pos ('L'); -- e_ident[EI_MAG2] + ELFMAG3 : constant Elf_Uchar := Character'Pos ('F'); -- e_ident[EI_MAG3] + + ELFCLASSNONE : constant Elf_Uchar := 0; -- Invalid class + ELFCLASS32 : constant Elf_Uchar := 1; -- 32-bit objects + ELFCLASS64 : constant Elf_Uchar := 2; -- 64-bit objects + + ELFDATANONE : constant Elf_Uchar := 0; -- Invalid data encoding + ELFDATA2LSB : constant Elf_Uchar := 1; -- See below + ELFDATA2MSB : constant Elf_Uchar := 2; -- See below + + SHN_UNDEF : constant Elf_Half := 0; -- + SHN_LORESERVE : constant Elf_Half := 16#Ff00#; -- + SHN_LOPROC : constant Elf_Half := 16#ff00#; -- + SHN_HIPROC : constant Elf_Half := 16#ff1f#; -- + SHN_ABS : constant Elf_Half := 16#fff1#; -- + SHN_COMMON : constant Elf_Half := 16#fff2#; -- + SHN_HIRESERVE : constant Elf_Half := 16#ffff#; -- + + -- Sh_type. + SHT_NULL : constant Elf_Word := 0; + SHT_PROGBITS : constant Elf_Word := 1; + SHT_SYMTAB : constant Elf_Word := 2; + SHT_STRTAB : constant Elf_Word := 3; + SHT_RELA : constant Elf_Word := 4; + SHT_HASH : constant Elf_Word := 5; + SHT_DYNAMIC : constant Elf_Word := 6; + SHT_NOTE : constant Elf_Word := 7; + SHT_NOBITS : constant Elf_Word := 8; + SHT_REL : constant Elf_Word := 9; + SHT_SHLIB : constant Elf_Word := 10; + SHT_DYNSYM : constant Elf_Word := 11; + SHT_INIT_ARRAY : constant Elf_Word := 14; + SHT_FINI_ARRAY : constant Elf_Word := 15; + SHT_PREINIT_ARRAY : constant Elf_Word := 16; + SHT_GROUP : constant Elf_Word := 17; + SHT_SYMTAB_SHNDX : constant Elf_Word := 18; + SHT_NUM : constant Elf_Word := 19; + SHT_LOOS : constant Elf_Word := 16#60000000#; + SHT_GNU_LIBLIST : constant Elf_Word := 16#6ffffff7#; + SHT_CHECKSUM : constant Elf_Word := 16#6ffffff8#; + SHT_LOSUNW : constant Elf_Word := 16#6ffffffa#; + SHT_SUNW_Move : constant Elf_Word := 16#6ffffffa#; + SHT_SUNW_COMDAT : constant Elf_Word := 16#6ffffffb#; + SHT_SUNW_Syminfo : constant Elf_Word := 16#6ffffffc#; + SHT_GNU_Verdef : constant Elf_Word := 16#6ffffffd#; + SHT_GNU_Verneed : constant Elf_Word := 16#6ffffffe#; + SHT_GNU_Versym : constant Elf_Word := 16#6fffffff#; + SHT_HISUNW : constant Elf_Word := 16#6fffffff#; + SHT_HIOS : constant Elf_Word := 16#6fffffff#; + SHT_LOPROC : constant Elf_Word := 16#70000000#; + SHT_HIPROC : constant Elf_Word := 16#7fffffff#; + SHT_LOUSER : constant Elf_Word := 16#80000000#; + SHT_HIUSER : constant Elf_Word := 16#ffffffff#; + + + SHF_WRITE : constant := 16#1#; + SHF_ALLOC : constant := 16#2#; + SHF_EXECINSTR : constant := 16#4#; + SHF_MASKPROC : constant := 16#F0000000#; + + function Elf_St_Bind (Info : Elf_Uchar) return Elf_Uchar; + function Elf_St_Type (Info : Elf_Uchar) return Elf_Uchar; + function Elf_St_Info (B, T : Elf_Uchar) return Elf_Uchar; + pragma Inline (Elf_St_Bind); + pragma Inline (Elf_St_Type); + pragma Inline (Elf_St_Info); + + -- Symbol binding. + STB_LOCAL : constant Elf_Uchar := 0; + STB_GLOBAL : constant Elf_Uchar := 1; + STB_WEAK : constant Elf_Uchar := 2; + STB_LOPROC : constant Elf_Uchar := 13; + STB_HIPROC : constant Elf_Uchar := 15; + + -- Symbol types. + STT_NOTYPE : constant Elf_Uchar := 0; + STT_OBJECT : constant Elf_Uchar := 1; + STT_FUNC : constant Elf_Uchar := 2; + STT_SECTION : constant Elf_Uchar := 3; + STT_FILE : constant Elf_Uchar := 4; + STT_LOPROC : constant Elf_Uchar := 13; + STT_HIPROC : constant Elf_Uchar := 15; + + + PT_NULL : constant Elf_Word := 0; + PT_LOAD : constant Elf_Word := 1; + PT_DYNAMIC : constant Elf_Word := 2; + PT_INTERP : constant Elf_Word := 3; + PT_NOTE : constant Elf_Word := 4; + PT_SHLIB : constant Elf_Word := 5; + PT_PHDR : constant Elf_Word := 6; + PT_TLS : constant Elf_Word := 7; + PT_NUM : constant Elf_Word := 8; + PT_LOOS : constant Elf_Word := 16#60000000#; + PT_GNU_EH_FRAME : constant Elf_Word := 16#6474e550#; + PT_LOSUNW : constant Elf_Word := 16#6ffffffa#; + PT_SUNWBSS : constant Elf_Word := 16#6ffffffa#; + PT_SUNWSTACK : constant Elf_Word := 16#6ffffffb#; + PT_HISUNW : constant Elf_Word := 16#6fffffff#; + PT_HIOS : constant Elf_Word := 16#6fffffff#; + PT_LOPROC : constant Elf_Word := 16#70000000#; + PT_HIPROC : constant Elf_Word := 16#7fffffff#; + + PF_X : constant Elf_Word := 1; + PF_W : constant Elf_Word := 2; + PF_R : constant Elf_Word := 4; + + DT_NULL : constant Elf_Word := 0; + DT_NEEDED : constant Elf_Word := 1; + DT_PLTRELSZ : constant Elf_Word := 2; + DT_PLTGOT : constant Elf_Word := 3; + DT_HASH : constant Elf_Word := 4; + DT_STRTAB : constant Elf_Word := 5; + DT_SYMTAB : constant Elf_Word := 6; + DT_RELA : constant Elf_Word := 7; + DT_RELASZ : constant Elf_Word := 8; + DT_RELAENT : constant Elf_Word := 9; + DT_STRSZ : constant Elf_Word := 10; + DT_SYMENT : constant Elf_Word := 11; + DT_INIT : constant Elf_Word := 12; + DT_FINI : constant Elf_Word := 13; + DT_SONAME : constant Elf_Word := 14; + DT_RPATH : constant Elf_Word := 15; + DT_SYMBOLIC : constant Elf_Word := 16; + DT_REL : constant Elf_Word := 17; + DT_RELSZ : constant Elf_Word := 18; + DT_RELENT : constant Elf_Word := 19; + DT_PLTREL : constant Elf_Word := 20; + DT_DEBUG : constant Elf_Word := 21; + DT_TEXTREL : constant Elf_Word := 22; + DT_JMPREL : constant Elf_Word := 23; + DT_BIND_NOW : constant Elf_Word := 24; + DT_INIT_ARRAY : constant Elf_Word := 25; + DT_FINI_ARRAY : constant Elf_Word := 26; + DT_INIT_ARRAYSZ : constant Elf_Word := 27; + DT_FINI_ARRAYSZ : constant Elf_Word := 28; + DT_RUNPATH : constant Elf_Word := 29; + DT_FLAGS : constant Elf_Word := 30; + DT_ENCODING : constant Elf_Word := 32; + DT_PREINIT_ARRAY : constant Elf_Word := 32; + DT_PREINIT_ARRAYSZ : constant Elf_Word := 33; + DT_NUM : constant Elf_Word := 34; + DT_LOOS : constant Elf_Word := 16#60000000#; + DT_HIOS : constant Elf_Word := 16#6fffffff#; + DT_LOPROC : constant Elf_Word := 16#70000000#; + DT_HIPROC : constant Elf_Word := 16#7fffffff#; + DT_VALRNGLO : constant Elf_Word := 16#6ffffd00#; + DT_GNU_PRELINKED : constant Elf_Word := 16#6ffffdf5#; + DT_GNU_CONFLICTSZ : constant Elf_Word := 16#6ffffdf6#; + DT_GNU_LIBLISTSZ : constant Elf_Word := 16#6ffffdf7#; + DT_CHECKSUM : constant Elf_Word := 16#6ffffdf8#; + DT_PLTPADSZ : constant Elf_Word := 16#6ffffdf9#; + DT_MOVEENT : constant Elf_Word := 16#6ffffdfa#; + DT_MOVESZ : constant Elf_Word := 16#6ffffdfb#; + DT_FEATURE_1 : constant Elf_Word := 16#6ffffdfc#; + DT_POSFLAG_1 : constant Elf_Word := 16#6ffffdfd#; + DT_SYMINSZ : constant Elf_Word := 16#6ffffdfe#; + DT_SYMINENT : constant Elf_Word := 16#6ffffdff#; + DT_VALRNGHI : constant Elf_Word := 16#6ffffdff#; + DT_ADDRRNGLO : constant Elf_Word := 16#6ffffe00#; + DT_GNU_CONFLICT : constant Elf_Word := 16#6ffffef8#; + DT_GNU_LIBLIST : constant Elf_Word := 16#6ffffef9#; + DT_CONFIG : constant Elf_Word := 16#6ffffefa#; + DT_DEPAUDIT : constant Elf_Word := 16#6ffffefb#; + DT_AUDIT : constant Elf_Word := 16#6ffffefc#; + DT_PLTPAD : constant Elf_Word := 16#6ffffefd#; + DT_MOVETAB : constant Elf_Word := 16#6ffffefe#; + DT_SYMINFO : constant Elf_Word := 16#6ffffeff#; + DT_ADDRRNGHI : constant Elf_Word := 16#6ffffeff#; + DT_VERSYM : constant Elf_Word := 16#6ffffff0#; + DT_RELACOUNT : constant Elf_Word := 16#6ffffff9#; + DT_RELCOUNT : constant Elf_Word := 16#6ffffffa#; + DT_FLAGS_1 : constant Elf_Word := 16#6ffffffb#; + DT_VERDEF : constant Elf_Word := 16#6ffffffc#; + DT_VERDEFNUM : constant Elf_Word := 16#6ffffffd#; + DT_VERNEED : constant Elf_Word := 16#6ffffffe#; + DT_VERNEEDNUM : constant Elf_Word := 16#6fffffff#; + DT_AUXILIARY : constant Elf_Word := 16#7ffffffd#; + DT_FILTER : constant Elf_Word := 16#7fffffff#; + +end Elf_Common; diff --git a/ortho/mcode/elfdump.adb b/ortho/mcode/elfdump.adb new file mode 100644 index 0000000..d492759 --- /dev/null +++ b/ortho/mcode/elfdump.adb @@ -0,0 +1,267 @@ +-- ELF dumper (main program). +-- 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 Ada.Text_IO; use Ada.Text_IO; +with Elf_Common; use Elf_Common; +with Ada.Command_Line; use Ada.Command_Line; +with Hex_Images; use Hex_Images; +with Interfaces; use Interfaces; +with Elfdumper; use Elfdumper; + +procedure Elfdump is + Flag_Ehdr : Boolean := False; + Flag_Shdr : Boolean := False; + Flag_Strtab : Boolean := False; + Flag_Symtab : Boolean := False; + Flag_Dwarf_Info : Boolean := False; + Flag_Dwarf_Abbrev : Boolean := False; + Flag_Dwarf_Pubnames : Boolean := False; + Flag_Dwarf_Aranges : Boolean := False; + Flag_Dwarf_Line : Boolean := False; + Flag_Dwarf_Frame : Boolean := False; + Flag_Eh_Frame_Hdr : Boolean := False; + Flag_Long_Shdr : Boolean := False; + Flag_Phdr : Boolean := False; + Flag_Note : Boolean := False; + Flag_Dynamic : Boolean := False; + + procedure Disp_Max_Len (Str : String; Len : Natural) + is + begin + if Str'Length > Len then + Put (Str (Str'First .. Str'First + Len - 1)); + else + Put (Str); + Put ((Str'Length + 1 .. Len => ' ')); + end if; + end Disp_Max_Len; + + procedure Disp_Section_Header (File : Elf_File; Index : Elf_Half) is + begin + Put ("Section " & Hex_Image (Index)); + Put (" "); + Put (Get_Section_Name (File, Index)); + New_Line; + end Disp_Section_Header; + + procedure Disp_Elf_File (Filename : String) + is + File : Elf_File; + Ehdr : Elf_Ehdr_Acc; + Shdr : Elf_Shdr_Acc; + Phdr : Elf_Phdr_Acc; + Sh_Strtab : Strtab_Type; + begin + Open_File (File, Filename); + if Get_Status (File) /= Status_Ok then + Put_Line ("cannot open elf file '" & Filename & "': " & + Elf_File_Status'Image (Get_Status (File))); + return; + end if; + + Ehdr := Get_Ehdr (File); + + if Flag_Ehdr then + Disp_Ehdr (Ehdr.all); + end if; + + Load_Shdr (File); + Sh_Strtab := Get_Sh_Strtab (File); + + if Flag_Long_Shdr then + if Ehdr.E_Shnum = 0 then + Put ("no section"); + else + for I in 0 .. Ehdr.E_Shnum - 1 loop + Put ("Section " & Hex_Image (I)); + New_Line; + Disp_Shdr (Get_Shdr (File, I).all, Sh_Strtab); + end loop; + end if; + end if; + if Flag_Shdr then + if Ehdr.E_Shnum = 0 then + Put ("no section"); + else + Put ("Num Name Type "); + Put ("Offset Size Link Info Al Es"); + New_Line; + for I in 0 .. Ehdr.E_Shnum - 1 loop + declare + Shdr : Elf_Shdr_Acc := Get_Shdr (File, I); + begin + Put (Hex_Image (I)); + Put (" "); + Disp_Max_Len (Get_Section_Name (File, I), 20); + Put (" "); + Disp_Max_Len (Get_Shdr_Type_Name (Shdr.Sh_Type), 10); + Put (" "); + Put (Hex_Image (Shdr.Sh_Offset)); + Put (" "); + Put (Hex_Image (Shdr.Sh_Size)); + Put (" "); + Put (Hex_Image (Unsigned_16 (Shdr.Sh_Link and 16#Ffff#))); + Put (" "); + Put (Hex_Image (Unsigned_16 (Shdr.Sh_Info and 16#Ffff#))); + Put (" "); + Put (Hex_Image (Unsigned_8 (Shdr.Sh_Addralign and 16#ff#))); + Put (" "); + Put (Hex_Image (Unsigned_8 (Shdr.Sh_Entsize and 16#ff#))); + New_Line; + end; + end loop; + end if; + end if; + + if Flag_Phdr then + Load_Phdr (File); + if Ehdr.E_Phnum = 0 then + Put ("no program segment"); + else + for I in 0 .. Ehdr.E_Phnum - 1 loop + Put ("segment " & Hex_Image (I)); + New_Line; + Disp_Phdr (Get_Phdr (File, I).all); + end loop; + end if; + end if; + + -- Dump each section. + if Ehdr.E_Shnum > 0 then + for I in 0 .. Ehdr.E_Shnum - 1 loop + Shdr := Get_Shdr (File, I); + case Shdr.Sh_Type is + when SHT_SYMTAB => + if Flag_Symtab then + Disp_Section_Header (File, I); + Disp_Symtab (File, I); + end if; + when SHT_STRTAB => + if Flag_Strtab then + Disp_Section_Header (File, I); + Disp_Strtab (File, I); + end if; + when SHT_PROGBITS => + declare + Name : String := Get_Section_Name (File, I); + begin + if Flag_Dwarf_Abbrev and then Name = ".debug_abbrev" then + Disp_Section_Header (File, I); + Disp_Debug_Abbrev (File, I); + elsif Flag_Dwarf_Info and then Name = ".debug_info" then + Disp_Section_Header (File, I); + Disp_Debug_Info (File, I); + elsif Flag_Dwarf_Line and then Name = ".debug_line" then + Disp_Section_Header (File, I); + Disp_Debug_Line (File, I); + elsif Flag_Dwarf_Frame and then Name = ".debug_frame" then + Disp_Section_Header (File, I); + Disp_Debug_Frame (File, I); + elsif Flag_Dwarf_Pubnames + and then Name = ".debug_pubnames" + then + Disp_Section_Header (File, I); + Disp_Debug_Pubnames (File, I); + elsif Flag_Eh_Frame_Hdr and then Name = ".eh_frame_hdr" + then + Disp_Section_Header (File, I); + Disp_Eh_Frame_Hdr (File, I); + elsif Flag_Dwarf_Aranges + and then Name = ".debug_aranges" + then + Disp_Section_Header (File, I); + Disp_Debug_Aranges (File, I); + end if; + end; + when SHT_NOTE => + if Flag_Note then + Disp_Section_Header (File, I); + Disp_Section_Note (File, I); + end if; + when SHT_DYNAMIC => + if Flag_Dynamic then + Disp_Section_Header (File, I); + Disp_Dynamic (File, I); + end if; + when others => + null; + end case; + end loop; + elsif Ehdr.E_Phnum > 0 then + Load_Phdr (File); + for I in 0 .. Ehdr.E_Phnum - 1 loop + Phdr := Get_Phdr (File, I); + case Phdr.P_Type is + when PT_NOTE => + if Flag_Note then + Disp_Segment_Note (File, I); + end if; + when others => + null; + end case; + end loop; + end if; + end Disp_Elf_File; + +begin + for I in 1 .. Argument_Count loop + declare + Arg : String := Argument (I); + begin + if Arg (1) = '-' then + -- An option. + if Arg = "-e" then + Flag_Ehdr := True; + elsif Arg = "-t" then + Flag_Strtab := True; + elsif Arg = "-S" then + Flag_Symtab := True; + elsif Arg = "-s" then + Flag_Shdr := True; + elsif Arg = "-p" then + Flag_Phdr := True; + elsif Arg = "-n" then + Flag_Note := True; + elsif Arg = "-d" then + Flag_Dynamic := True; + elsif Arg = "--dwarf-info" then + Flag_Dwarf_Info := True; + elsif Arg = "--dwarf-abbrev" then + Flag_Dwarf_Abbrev := True; + elsif Arg = "--dwarf-line" then + Flag_Dwarf_Line := True; + elsif Arg = "--dwarf-frame" then + Flag_Dwarf_Frame := True; + elsif Arg = "--dwarf-pubnames" then + Flag_Dwarf_Pubnames := True; + elsif Arg = "--dwarf-aranges" then + Flag_Dwarf_Aranges := True; + elsif Arg = "--eh-frame-hdr" then + Flag_Eh_Frame_Hdr := True; + elsif Arg = "--long-shdr" then + Flag_Long_Shdr := True; + else + Put_Line ("unknown option '" & Arg & "'"); + return; + end if; + else + Disp_Elf_File (Arg); + end if; + end; + end loop; +end Elfdump; + diff --git a/ortho/mcode/elfdumper.adb b/ortho/mcode/elfdumper.adb new file mode 100644 index 0000000..b3a3b70 --- /dev/null +++ b/ortho/mcode/elfdumper.adb @@ -0,0 +1,2818 @@ +-- ELF dumper (library). +-- 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 System.Storage_Elements; use System.Storage_Elements; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Unchecked_Deallocation; +with GNAT.OS_Lib; +with Interfaces; use Interfaces; +with Hex_Images; use Hex_Images; +with Elf_Common; use Elf_Common; +with Dwarf; + +package body Elfdumper is + function Get_String (Strtab : Strtab_Type; N : Elf_Size) return String + is + E : Elf_Size; + begin + E := N; + while Strtab.Base (E) /= Nul loop + E := E + 1; + end loop; + if E = N then + return ""; + else + return String (Strtab.Base (N .. E - 1)); + end if; + end Get_String; + + procedure Disp_Ehdr (Ehdr : Elf_Ehdr) is + begin + Put ("File class: "); + case Ehdr.E_Ident (EI_CLASS) is + when ELFCLASSNONE => + Put ("none"); + when ELFCLASS32 => + Put ("class_32"); + when ELFCLASS64 => + Put ("class_64"); + when others => + Put ("others"); + end case; + New_Line; + + Put ("encoding : "); + case Ehdr.E_Ident (EI_DATA) is + when ELFDATANONE => + Put ("none"); + when ELFDATA2LSB => + Put ("LSB byte order"); + when ELFDATA2MSB => + Put ("MSB byte order"); + when others => + Put ("unknown"); + end case; + New_Line; + + Put ("version : "); + case Ehdr.E_Ident (EI_VERSION) is + when EV_NONE => + Put ("none"); + when EV_CURRENT => + Put ("current (1)"); + when others => + Put ("future"); + end case; + New_Line; + + if Ehdr.E_Ident (EI_CLASS) /= Elf_Arch_Class +-- or Ehdr.E_Ident (EI_DATA) /= ELFDATA2LSB + or Ehdr.E_Ident (EI_VERSION) /= EV_CURRENT + then + Put_Line ("bad class/data encoding/version"); + return; + end if; + + Put ("File type : "); + case Ehdr.E_Type is + when ET_NONE => + Put ("no file type"); + when ET_REL => + Put ("relocatable file"); + when ET_EXEC => + Put ("executable file"); + when ET_CORE => + Put ("core file"); + when ET_LOPROC .. ET_HIPROC => + Put ("processor-specific"); + when others => + Put ("unknown"); + end case; + New_Line; + + Put ("machine : "); + case Ehdr.E_Machine is + when EM_NONE => + Put ("no machine"); + when EM_M32 => + Put ("AT&T WE 32100"); + when EM_SPARC => + Put ("SPARC"); + when EM_386 => + Put ("Intel architecture"); + when EM_68K => + Put ("Motorola 68000"); + when EM_88K => + Put ("Motorola 88000"); + when EM_860 => + Put ("Intel 80860"); + when EM_MIPS => + Put ("MIPS RS3000 Big-Endian"); + when EM_MIPS_RS4_BE => + Put ("MIPS RS4000 Big-Endian"); + when others => + Put ("unknown"); + end case; + New_Line; + + Put_Line ("Version : " & Hex_Image (Ehdr.E_Version)); + Put_Line ("Phoff : " & Hex_Image (Ehdr.E_Phoff)); + Put_Line ("Shoff : " & Hex_Image (Ehdr.E_Shoff)); + Put_Line ("flags : " & Hex_Image (Ehdr.E_Flags)); + Put_Line ("phentsize : " & Hex_Image (Ehdr.E_Ehsize)); + Put_Line ("phnum : " & Hex_Image (Ehdr.E_Phentsize)); + Put_Line ("shentsize : " & Hex_Image (Ehdr.E_Shentsize)); + Put_Line ("shnum : " & Hex_Image (Ehdr.E_Shnum)); + Put_Line ("shstrndx : " & Hex_Image (Ehdr.E_Shstrndx)); + end Disp_Ehdr; + + function Get_Shdr_Type_Name (Stype : Elf_Word) return String is + begin + case Stype is + when SHT_NULL => + return "NULL"; + when SHT_PROGBITS => + return "PROGBITS"; + when SHT_SYMTAB => + return "SYMTAB"; + when SHT_STRTAB => + return "STRTAB"; + when SHT_RELA => + return "RELA"; + when SHT_HASH => + return "HASH"; + when SHT_DYNAMIC => + return "DYNAMIC"; + when SHT_NOTE => + return "NOTE"; + when SHT_NOBITS => + return "NOBITS"; + when SHT_REL => + return "REL"; + when SHT_SHLIB => + return "SHLIB"; + when SHT_DYNSYM => + return "DYNSYM"; + when SHT_INIT_ARRAY => + return "INIT_ARRAY"; + when SHT_FINI_ARRAY => + return "FINI_ARRAY"; + when SHT_PREINIT_ARRAY => + return "PREINIT_ARRAY"; + when SHT_GROUP => + return "GROUP"; + when SHT_SYMTAB_SHNDX => + return "SYMTAB_SHNDX"; + when SHT_NUM => + return "NUM"; + when SHT_LOOS => + return "LOOS"; + when SHT_GNU_LIBLIST => + return "GNU_LIBLIST"; + when SHT_CHECKSUM => + return "CHECKSUM"; + when SHT_SUNW_Move => + return "SUNW_move"; + when SHT_SUNW_COMDAT => + return "SUNW_COMDAT"; + when SHT_SUNW_Syminfo => + return "SUNW_syminfo"; + when SHT_GNU_Verdef => + return "GNU_verdef"; + when SHT_GNU_Verneed => + return "GNU_verneed"; + when SHT_GNU_Versym => + return "GNU_versym"; + when SHT_LOPROC .. SHT_HIPROC => + return "Processor dependant"; + when SHT_LOUSER .. SHT_HIUSER => + return "User dependant"; + when others => + return "unknown"; + end case; + end Get_Shdr_Type_Name; + + procedure Disp_Shdr (Shdr : Elf_Shdr; Sh_Strtab : Strtab_Type) + is + begin + Put_Line ("name : " & Hex_Image (Shdr.Sh_Name) & " """ + & Get_String (Sh_Strtab, Elf_Size (Shdr.Sh_Name)) & """"); + Put ("type : " & Hex_Image (Shdr.Sh_Type) & " "); + Put (Get_Shdr_Type_Name (Shdr.Sh_Type)); + New_Line; + Put ("flags : " & Hex_Image (Shdr.Sh_Flags)); + if (Shdr.Sh_Flags and SHF_WRITE) /= 0 then + Put (" WRITE"); + end if; + if (Shdr.Sh_Flags and SHF_ALLOC) /= 0 then + Put (" ALLOC"); + end if; + if (Shdr.Sh_Flags and SHF_EXECINSTR) /= 0 then + Put (" EXEC"); + end if; + New_Line; + Put ("addr : " & Hex_Image (Shdr.Sh_Addr)); + Put (" offset : " & Hex_Image (Shdr.Sh_Offset)); + Put (" size : " & Hex_Image (Shdr.Sh_Size)); + New_Line; + Put ("link : " & Hex_Image (Shdr.Sh_Link)); + Put (" info : " & Hex_Image (Shdr.Sh_Info)); + Put (" addralign : " & Hex_Image (Shdr.Sh_Addralign)); + Put (" entsize : " & Hex_Image (Shdr.Sh_Entsize)); + New_Line; + end Disp_Shdr; + + procedure Disp_Sym (File : Elf_File; + Sym : Elf_Sym; + Strtab : Strtab_Type) + is + begin + Put (Hex_Image (Sym.St_Value)); + Put (" " & Hex_Image (Sym.St_Size)); + Put (' '); + --Put (" info:" & Hex_Image (Sym.St_Info) & " "); + case Elf_St_Bind (Sym.St_Info) is + when STB_LOCAL => + Put ("loc "); + when STB_GLOBAL => + Put ("glob"); + when STB_WEAK => + Put ("weak"); + when others => + Put ("? "); + end case; + Put (' '); + case Elf_St_Type (Sym.St_Info) is + when STT_NOTYPE => + Put ("none"); + when STT_OBJECT => + Put ("obj "); + when STT_FUNC => + Put ("func"); + when STT_SECTION => + Put ("sect"); + when STT_FILE => + Put ("file"); + when others => + Put ("? "); + end case; + --Put (" other:" & Hex_Image (Sym.St_Other)); + Put (' '); + case Sym.St_Shndx is + when SHN_UNDEF => + Put ("UNDEF "); + when 1 .. SHN_LORESERVE - 1 => + declare + S : String := Get_Section_Name (File, Sym.St_Shndx); + Max : constant Natural := 8; + begin + if S'Length <= Max then + Put (S); + for I in S'Length + 1 .. Max loop + Put (' '); + end loop; + else + Put (S (S'First .. S'First + Max - 1)); + end if; + end; + when SHN_LOPROC .. SHN_HIPROC => + Put ("*proc* "); + when SHN_ABS => + Put ("*ABS* "); + when SHN_COMMON => + Put ("*COMMON*"); + when others => + Put ("?? "); + end case; + --Put (" sect:" & Hex_Image (Sym.St_Shndx)); + Put (' '); + Put_Line (Get_String (Strtab, Elf_Size (Sym.St_Name))); + end Disp_Sym; + + function Get_Offset (File : Elf_File; Off : Elf_Off; Size : Elf_Size) + return Address + is + begin + if Off > File.Length or Off + Size > File.Length then + return Null_Address; + end if; + return File.Base + Storage_Offset (Off); + end Get_Offset; + + function Get_Section_Base (File : Elf_File; Shdr : Elf_Shdr) + return Address + is + begin + return Get_Offset (File, Shdr.Sh_Offset, Shdr.Sh_Size); + end Get_Section_Base; + + function Get_Section_Base (File : Elf_File; Index : Elf_Half) + return Address + is + Shdr : Elf_Shdr_Acc; + begin + Shdr := Get_Shdr (File, Index); + return Get_Section_Base (File, Shdr.all); + end Get_Section_Base; + + function Get_Segment_Base (File : Elf_File; Phdr : Elf_Phdr) + return Address + is + begin + return Get_Offset (File, Phdr.P_Offset, Phdr.P_Filesz); + end Get_Segment_Base; + + function Get_Segment_Base (File : Elf_File; Index : Elf_Half) + return Address + is + Phdr : Elf_Phdr_Acc; + begin + Phdr := Get_Phdr (File, Index); + return Get_Segment_Base (File, Phdr.all); + end Get_Segment_Base; + + procedure Open_File (File : out Elf_File; Filename : String) + is + function Malloc (Size : Integer) return Address; + pragma Import (C, Malloc); + + use GNAT.OS_Lib; + Length : Long_Integer; + Len : Integer; + Fd : File_Descriptor; + begin + File := (Filename => new String'(Filename), + Status => Status_Ok, + Length => 0, + Base => Null_Address, + Ehdr => null, + Shdr_Base => Null_Address, + Sh_Strtab => (null, 0), + Phdr_Base => Null_Address); + + -- Open the file. + Fd := Open_Read (Filename, Binary); + if Fd = Invalid_FD then + File.Status := Status_Open_Failure; + return; + end if; + + -- Get length. + Length := File_Length (Fd); + Len := Integer (Length); + if Len < Elf_Ehdr_Size then + File.Status := Status_Bad_File; + Close (Fd); + return; + end if; + + File.Length := Elf_Off (Len); + + -- Allocate memory for the file. + File.Base := Malloc (Len); + if File.Base = Null_Address then + File.Status := Status_Memory; + Close (Fd); + return; + end if; + + -- Read the whole file. + if Read (Fd, File.Base, Integer (Length)) /= Integer (Length) then + File.Status := Status_Read_Error; + Close (Fd); + return; + end if; + + Close (Fd); + + File.Ehdr := To_Elf_Ehdr_Acc (File.Base); + + if File.Ehdr.E_Ident (EI_MAG0) /= ELFMAG0 + or File.Ehdr.E_Ident (EI_MAG1) /= ELFMAG1 + or File.Ehdr.E_Ident (EI_MAG2) /= ELFMAG2 + or File.Ehdr.E_Ident (EI_MAG3) /= ELFMAG3 + then + File.Status := Status_Bad_Magic; + return; + end if; + + if File.Ehdr.E_Ident (EI_CLASS) /= Elf_Arch_Class +-- or Ehdr.E_Ident (EI_DATA) /= ELFDATA2LSB + or File.Ehdr.E_Ident (EI_VERSION) /= EV_CURRENT + then + File.Status := Status_Bad_Class; + return; + end if; + end Open_File; + + function Get_Status (File : Elf_File) return Elf_File_Status is + begin + return File.Status; + end Get_Status; + + function Get_Ehdr (File : Elf_File) return Elf_Ehdr_Acc is + begin + return File.Ehdr; + end Get_Ehdr; + + function Get_Shdr (File : Elf_File; Index : Elf_Half) + return Elf_Shdr_Acc + is + begin + if Index >= File.Ehdr.E_Shnum then + raise Constraint_Error; + end if; + return To_Elf_Shdr_Acc + (File.Shdr_Base + + Storage_Offset (Index * Elf_Half (Elf_Shdr_Size))); + end Get_Shdr; + + procedure Load_Phdr (File : in out Elf_File) + is + begin + if Get_Ehdr (File).E_Phentsize /= Elf_Half (Elf_Phdr_Size) then + return; + end if; + + File.Phdr_Base := + Get_Offset (File, Get_Ehdr (File).E_Phoff, + Elf_Size (Get_Ehdr (File).E_Phnum + * Elf_Half (Elf_Phdr_Size))); + end Load_Phdr; + + function Get_Phdr (File : Elf_File; Index : Elf_Half) + return Elf_Phdr_Acc + is + begin + if Index >= File.Ehdr.E_Phnum then + raise Constraint_Error; + end if; + return To_Elf_Phdr_Acc + (File.Phdr_Base + + Storage_Offset (Index * Elf_Half (Elf_Phdr_Size))); + end Get_Phdr; + + function Get_Strtab (File : Elf_File; Index : Elf_Half) + return Strtab_Type + is + Shdr : Elf_Shdr_Acc; + begin + Shdr := Get_Shdr (File, Index); + if Shdr = null or Shdr.Sh_Type /= SHT_STRTAB then + return Null_Strtab; + end if; + return (Base => To_Strtab_Fat_Acc (Get_Section_Base (File, Shdr.all)), + Length => Shdr.Sh_Size); + end Get_Strtab; + + procedure Load_Shdr (File : in out Elf_File) + is + begin + if Get_Ehdr (File).E_Shentsize /= Elf_Half (Elf_Shdr_Size) then + return; + end if; + + File.Shdr_Base := + Get_Offset (File, Get_Ehdr (File).E_Shoff, + Elf_Size (Get_Ehdr (File).E_Shnum + * Elf_Half (Elf_Shdr_Size))); + File.Sh_Strtab := Get_Strtab (File, Get_Ehdr (File).E_Shstrndx); + end Load_Shdr; + + function Get_Sh_Strtab (File : Elf_File) return Strtab_Type is + begin + return File.Sh_Strtab; + end Get_Sh_Strtab; + + function Get_Section_Name (File : Elf_File; Index : Elf_Half) + return String + is + begin + return Get_String (Get_Sh_Strtab (File), + Elf_Size (Get_Shdr (File, Index).Sh_Name)); + end Get_Section_Name; + + function Get_Section_By_Name (File : Elf_File; Name : String) + return Elf_Half + is + Ehdr : Elf_Ehdr_Acc; + Shdr : Elf_Shdr_Acc; + Sh_Strtab : Strtab_Type; + begin + Ehdr := Get_Ehdr (File); + Sh_Strtab := Get_Sh_Strtab (File); + for I in 1 .. Ehdr.E_Shnum - 1 loop + Shdr := Get_Shdr (File, I); + if Get_String (Sh_Strtab, Elf_Size (Shdr.Sh_Name)) = Name then + return I; + end if; + end loop; + return 0; + end Get_Section_By_Name; + + procedure Disp_Symtab (File : Elf_File; Index : Elf_Half) + is + Shdr : Elf_Shdr_Acc; + S_Strtab : Strtab_Type; + Base : Address; + Off : Storage_Offset; + begin + Shdr := Get_Shdr (File, Index); + if Shdr.Sh_Entsize /= Elf_Size (Elf_Sym_Size) then + return; + end if; + S_Strtab := Get_Strtab (File, Elf_Half (Shdr.Sh_Link)); + Base := Get_Section_Base (File, Shdr.all); + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Disp_Sym (File, To_Elf_Sym_Acc (Base + Off).all, S_Strtab); + Off := Off + Storage_Offset (Elf_Sym_Size); + end loop; + end Disp_Symtab; + + procedure Disp_Strtab (File : Elf_File; Index : Elf_Half) + is + Strtab : Strtab_Type; + S, E : Elf_Size; + begin + Strtab := Get_Strtab (File, Index); + S := 1; + while S < Strtab.Length loop + E := S; + while Strtab.Base (E) /= Nul loop + E := E + 1; + end loop; + Put_Line (Hex_Image (S) & ": " + & String (Strtab.Base (S .. E - 1))); + S := E + 1; + end loop; + end Disp_Strtab; + + 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_ULEB128 (Base : Address; + Off : in out Storage_Offset; + Res : out Unsigned_32) + is + B : Unsigned_8; + Shift : Integer; + begin + Res := 0; + Shift := 0; + loop + B := Read_Byte (Base + Off); + Off := Off + 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 (Base : Address; + Off : in out Storage_Offset; + Res : out Unsigned_32) + is + B : Unsigned_8; + Shift : Integer; + begin + Res := 0; + Shift := 0; + loop + B := Read_Byte (Base + Off); + Off := Off + 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 Read_Word4 (Base : Address; + Off : in out Storage_Offset; + Res : out Unsigned_32) + is + B0, B1, B2, B3 : Unsigned_8; + begin + B0 := Read_Byte (Base + Off + 0); + B1 := Read_Byte (Base + Off + 1); + B2 := Read_Byte (Base + Off + 2); + B3 := Read_Byte (Base + Off + 3); + 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); + Off := Off + 4; + end Read_Word4; + + procedure Read_Word2 (Base : Address; + Off : in out Storage_Offset; + Res : out Unsigned_16) + is + B0, B1 : Unsigned_8; + begin + B0 := Read_Byte (Base + Off + 0); + B1 := Read_Byte (Base + Off + 1); + Res := Shift_Left (Unsigned_16 (B1), 8) + or Shift_Left (Unsigned_16 (B0), 0); + Off := Off + 2; + end Read_Word2; + + procedure Read_Byte (Base : Address; + Off : in out Storage_Offset; + Res : out Unsigned_8) + is + begin + Res := Read_Byte (Base + Off); + Off := Off + 1; + end Read_Byte; + + procedure Disp_Note (Base : Address; Size : Storage_Offset) + is + Off : Storage_Offset; + Namesz : Unsigned_32; + Descsz : Unsigned_32; + Ntype : Unsigned_32; + B : Unsigned_8; + Is_Full : Boolean; + begin + Off := 0; + while Off < Size loop + Read_Word4 (Base, Off, Namesz); + Read_Word4 (Base, Off, Descsz); + Read_Word4 (Base, Off, Ntype); + Put ("type : "); + Put (Hex_Image (Ntype)); + New_Line; + Put ("name : "); + Put (Hex_Image (Namesz)); + Put (" "); + for I in 1 .. Namesz loop + Read_Byte (Base, Off, B); + if B /= 0 then + Put (Character'Val (B)); + end if; + end loop; + if Namesz mod 4 /= 0 then + for I in (Namesz mod 4) .. 3 loop + Read_Byte (Base, Off, B); + end loop; + end if; + New_Line; + Put ("desc : "); + Put (Hex_Image (Descsz)); + Put (" "); + Is_Full := Descsz >= 20; + for I in 1 .. Descsz loop + if Is_Full and (I mod 16) = 1 then + New_Line; + end if; + Read_Byte (Base, Off, B); + Put (' '); + Put (Hex_Image (B)); + end loop; + if Descsz mod 4 /= 0 then + for I in (Descsz mod 4) .. 3 loop + Read_Byte (Base, Off, B); + end loop; + end if; + New_Line; + end loop; + end Disp_Note; + + procedure Disp_Section_Note (File : Elf_File; Index : Elf_Half) + is + Shdr : Elf_Shdr_Acc; + Base : Address; + begin + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + Disp_Note (Base, Storage_Offset (Shdr.Sh_Size)); + end Disp_Section_Note; + + procedure Disp_Segment_Note (File : Elf_File; Index : Elf_Half) + is + Phdr : Elf_Phdr_Acc; + Base : Address; + begin + Phdr := Get_Phdr (File, Index); + Base := Get_Segment_Base (File, Phdr.all); + Disp_Note (Base, Storage_Offset (Phdr.P_Filesz)); + end Disp_Segment_Note; + + + function Get_Dt_Name (Name : Elf_Word) return String is + begin + case Name is + when DT_NULL => + return "NULL"; + when DT_NEEDED => + return "NEEDED"; + when DT_PLTRELSZ => + return "PLTRELSZ"; + when DT_PLTGOT => + return "PLTGOT"; + when DT_HASH => + return "HASH"; + when DT_STRTAB => + return "STRTAB"; + when DT_SYMTAB => + return "SYMTAB"; + when DT_RELA => + return "RELA"; + when DT_RELASZ => + return "RELASZ"; + when DT_RELAENT => + return "RELAENT"; + when DT_STRSZ => + return "STRSZ"; + when DT_SYMENT => + return "SYMENT"; + when DT_INIT => + return "INIT"; + when DT_FINI => + return "FINI"; + when DT_SONAME => + return "SONAME"; + when DT_RPATH => + return "RPATH"; + when DT_SYMBOLIC => + return "SYMBOLIC"; + when DT_REL => + return "REL"; + when DT_RELSZ => + return "RELSZ"; + when DT_RELENT => + return "RELENT"; + when DT_PLTREL => + return "PLTREL"; + when DT_DEBUG => + return "DEBUG"; + when DT_TEXTREL => + return "TEXTREL"; + when DT_JMPREL => + return "JMPREL"; + when DT_BIND_NOW => + return "BIND_NOW"; + when DT_INIT_ARRAY => + return "INIT_ARRAY"; + when DT_FINI_ARRAY => + return "FINI_ARRAY"; + when DT_INIT_ARRAYSZ => + return "INIT_ARRAYSZ"; + when DT_FINI_ARRAYSZ => + return "FINI_ARRAYSZ"; + when DT_RUNPATH => + return "RUNPATH"; + when DT_FLAGS => + return "FLAGS"; +-- when DT_ENCODING => +-- return "ENCODING"; + when DT_PREINIT_ARRAY => + return "PREINIT_ARRAY"; + when DT_PREINIT_ARRAYSZ => + return "PREINIT_ARRAYSZ"; + when DT_NUM => + return "NUM"; + when DT_LOOS => + return "LOOS"; +-- when DT_HIOS => +-- return "HIOS"; + when DT_LOPROC => + return "LOPROC"; +-- when DT_HIPROC => +-- return "HIPROC"; + when DT_VALRNGLO => + return "VALRNGLO"; + when DT_GNU_PRELINKED => + return "GNU_PRELINKED"; + when DT_GNU_CONFLICTSZ => + return "GNU_CONFLICTSZ"; + when DT_GNU_LIBLISTSZ => + return "GNU_LIBLISTSZ"; + when DT_CHECKSUM => + return "CHECKSUM"; + when DT_PLTPADSZ => + return "PLTPADSZ"; + when DT_MOVEENT => + return "MOVEENT"; + when DT_MOVESZ => + return "MOVESZ"; + when DT_FEATURE_1 => + return "FEATURE_1"; + when DT_POSFLAG_1 => + return "POSFLAG_1"; + when DT_SYMINSZ => + return "SYMINSZ"; + when DT_SYMINENT => + return "SYMINENT"; +-- when DT_VALRNGHI => +-- return "VALRNGHI"; + when DT_ADDRRNGLO => + return "ADDRRNGLO"; + when DT_GNU_CONFLICT => + return "GNU_CONFLICT"; + when DT_GNU_LIBLIST => + return "GNU_LIBLIST"; + when DT_CONFIG => + return "CONFIG"; + when DT_DEPAUDIT => + return "DEPAUDIT"; + when DT_AUDIT => + return "AUDIT"; + when DT_PLTPAD => + return "PLTPAD"; + when DT_MOVETAB => + return "MOVETAB"; + when DT_SYMINFO => + return "SYMINFO"; +-- when DT_ADDRRNGHI => +-- return "ADDRRNGHI"; + when DT_VERSYM => + return "VERSYM"; + when DT_RELACOUNT => + return "RELACOUNT"; + when DT_RELCOUNT => + return "RELCOUNT"; + when DT_FLAGS_1 => + return "FLAGS_1"; + when DT_VERDEF => + return "VERDEF"; + when DT_VERDEFNUM => + return "VERDEFNUM"; + when DT_VERNEED => + return "VERNEED"; + when DT_VERNEEDNUM => + return "VERNEEDNUM"; + when DT_AUXILIARY => + return "AUXILIARY"; + when DT_FILTER => + return "FILTER"; + when others => + return "?unknown?"; + end case; + end Get_Dt_Name; + + procedure Disp_Dynamic (File : Elf_File; Index : Elf_Half) + is + Shdr : Elf_Shdr_Acc; + Base : Address; + Off : Storage_Offset; + Tag : Unsigned_32; + Val : Unsigned_32; + begin + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Read_Word4 (Base, Off, Tag); + Read_Word4 (Base, Off, Val); + Put ("tag : "); + Put (Hex_Image (Tag)); + Put (" ("); + Put (Get_Dt_Name (Tag)); + Put (")"); + Set_Col (34); + Put ("val : "); + Put (Hex_Image (Val)); + New_Line; + end loop; + end Disp_Dynamic; + + function Get_Dwarf_Form_Name (Name : Unsigned_32) return String + is + use Dwarf; + begin + case Name is + when DW_FORM_Addr => + return "addr"; + when DW_FORM_Block2 => + return "block2"; + when DW_FORM_Block4 => + return "block4"; + when DW_FORM_Data2 => + return "data2"; + when DW_FORM_Data4 => + return "data4"; + when DW_FORM_Data8 => + return "data8"; + when DW_FORM_String => + return "string"; + when DW_FORM_Block => + return "block"; + when DW_FORM_Block1 => + return "block1"; + when DW_FORM_Data1 => + return "data1"; + when DW_FORM_Flag => + return "flag"; + when DW_FORM_Sdata => + return "sdata"; + when DW_FORM_Strp => + return "strp"; + when DW_FORM_Udata => + return "udata"; + when DW_FORM_Ref_Addr => + return "ref_addr"; + when DW_FORM_Ref1 => + return "ref1"; + when DW_FORM_Ref2 => + return "ref2"; + when DW_FORM_Ref4 => + return "ref4"; + when DW_FORM_Ref8 => + return "ref8"; + when DW_FORM_Ref_Udata => + return "ref_udata"; + when DW_FORM_Indirect => + return "indirect"; + when others => + return "unknown"; + end case; + end Get_Dwarf_Form_Name; + + function Get_Dwarf_Tag_Name (Tag : Unsigned_32) return String + is + use Dwarf; + begin + case Tag is + when DW_TAG_Array_Type => + return "array_type"; + when DW_TAG_Class_Type => + return "class_type"; + when DW_TAG_Entry_Point => + return "entry_point"; + when DW_TAG_Enumeration_Type => + return "enumeration_type"; + when DW_TAG_Formal_Parameter => + return "formal_parameter"; + when DW_TAG_Imported_Declaration => + return "imported_declaration"; + when DW_TAG_Label => + return "label"; + when DW_TAG_Lexical_Block => + return "lexical_block"; + when DW_TAG_Member => + return "member"; + when DW_TAG_Pointer_Type => + return "pointer_type"; + when DW_TAG_Reference_Type => + return "reference_type"; + when DW_TAG_Compile_Unit => + return "compile_unit"; + when DW_TAG_String_Type => + return "string_type"; + when DW_TAG_Structure_Type => + return "structure_type"; + when DW_TAG_Subroutine_Type => + return "subroutine_type"; + when DW_TAG_Typedef => + return "typedef"; + when DW_TAG_Union_Type => + return "union_type"; + when DW_TAG_Unspecified_Parameters => + return "unspecified_parameters"; + when DW_TAG_Variant => + return "variant"; + when DW_TAG_Common_Block => + return "common_block"; + when DW_TAG_Common_Inclusion => + return "common_inclusion"; + when DW_TAG_Inheritance => + return "inheritance"; + when DW_TAG_Inlined_Subroutine => + return "inlined_subroutine"; + when DW_TAG_Module => + return "module"; + when DW_TAG_Ptr_To_Member_Type => + return "ptr_to_member_type"; + when DW_TAG_Set_Type => + return "set_type"; + when DW_TAG_Subrange_Type => + return "subrange_type"; + when DW_TAG_With_Stmt => + return "with_stmt"; + when DW_TAG_Access_Declaration => + return "access_declaration"; + when DW_TAG_Base_Type => + return "base_type"; + when DW_TAG_Catch_Block => + return "catch_block"; + when DW_TAG_Const_Type => + return "const_type"; + when DW_TAG_Constant => + return "constant"; + when DW_TAG_Enumerator => + return "enumerator"; + when DW_TAG_File_Type => + return "file_type"; + when DW_TAG_Friend => + return "friend"; + when DW_TAG_Namelist => + return "namelist"; + when DW_TAG_Namelist_Item => + return "namelist_item"; + when DW_TAG_Packed_Type => + return "packed_type"; + when DW_TAG_Subprogram => + return "subprogram"; + when DW_TAG_Template_Type_Parameter => + return "template_type_parameter"; + when DW_TAG_Template_Value_Parameter => + return "template_value_parameter"; + when DW_TAG_Thrown_Type => + return "thrown_type"; + when DW_TAG_Try_Block => + return "try_block"; + when DW_TAG_Variant_Part => + return "variant_part"; + when DW_TAG_Variable => + return "variable"; + when DW_TAG_Volatile_Type => + return "volatile_type"; + when DW_TAG_Dwarf_Procedure => + return "dwarf_procedure"; + when DW_TAG_Restrict_Type => + return "restrict_type"; + when DW_TAG_Interface_Type => + return "interface_type"; + when DW_TAG_Namespace => + return "namespace"; + when DW_TAG_Imported_Module => + return "imported_module"; + when DW_TAG_Unspecified_Type => + return "unspecified_type"; + when DW_TAG_Partial_Unit => + return "partial_unit"; + when DW_TAG_Imported_Unit => + return "imported_unit"; + when DW_TAG_Mutable_Type => + return "mutable_type"; + when others => + return "unknown"; + end case; + end Get_Dwarf_Tag_Name; + + function Get_Dwarf_At_Name (Attr : Unsigned_32) return String + is + use Dwarf; + begin + case Attr is + when DW_AT_Sibling => + return "sibling"; + when DW_AT_Location => + return "location"; + when DW_AT_Name => + return "name"; + when DW_AT_Ordering => + return "ordering"; + when DW_AT_Byte_Size => + return "byte_size"; + when DW_AT_Bit_Offset => + return "bit_offset"; + when DW_AT_Bit_Size => + return "bit_size"; + when DW_AT_Stmt_List => + return "stmt_list"; + when DW_AT_Low_Pc => + return "low_pc"; + when DW_AT_High_Pc => + return "high_pc"; + when DW_AT_Language => + return "language"; + when DW_AT_Discr => + return "discr"; + when DW_AT_Discr_Value => + return "discr_value"; + when DW_AT_Visibility => + return "visibility"; + when DW_AT_Import => + return "import"; + when DW_AT_String_Length => + return "string_length"; + when DW_AT_Common_Reference => + return "common_reference"; + when DW_AT_Comp_Dir => + return "comp_dir"; + when DW_AT_Const_Value => + return "const_value"; + when DW_AT_Containing_Type => + return "containing_type"; + when DW_AT_Default_Value => + return "default_value"; + when DW_AT_Inline => + return "inline"; + when DW_AT_Is_Optional => + return "is_optional"; + when DW_AT_Lower_Bound => + return "lower_bound"; + when DW_AT_Producer => + return "producer"; + when DW_AT_Prototyped => + return "prototyped"; + when DW_AT_Return_Addr => + return "return_addr"; + when DW_AT_Start_Scope => + return "start_scope"; + when DW_AT_Stride_Size => + return "stride_size"; + when DW_AT_Upper_Bound => + return "upper_bound"; + when DW_AT_Abstract_Origin => + return "abstract_origin"; + when DW_AT_Accessibility => + return "accessibility"; + when DW_AT_Address_Class => + return "address_class"; + when DW_AT_Artificial => + return "artificial"; + when DW_AT_Base_Types => + return "base_types"; + when DW_AT_Calling_Convention => + return "calling_convention"; + when DW_AT_Count => + return "count"; + when DW_AT_Data_Member_Location => + return "data_member_location"; + when DW_AT_Decl_Column => + return "decl_column"; + when DW_AT_Decl_File => + return "decl_file"; + when DW_AT_Decl_Line => + return "decl_line"; + when DW_AT_Declaration => + return "declaration"; + when DW_AT_Discr_List => + return "discr_list"; + when DW_AT_Encoding => + return "encoding"; + when DW_AT_External => + return "external"; + when DW_AT_Frame_Base => + return "frame_base"; + when DW_AT_Friend => + return "friend"; + when DW_AT_Identifier_Case => + return "identifier_case"; + when DW_AT_Macro_Info => + return "macro_info"; + when DW_AT_Namelist_Item => + return "namelist_item"; + when DW_AT_Priority => + return "priority"; + when DW_AT_Segment => + return "segment"; + when DW_AT_Specification => + return "specification"; + when DW_AT_Static_Link => + return "static_link"; + when DW_AT_Type => + return "type"; + when DW_AT_Use_Location => + return "use_location"; + when DW_AT_Variable_Parameter => + return "variable_parameter"; + when DW_AT_Virtuality => + return "virtuality"; + when DW_AT_Vtable_Elem_Location => + return "vtable_elem_location"; + when DW_AT_Allocated => + return "allocated"; + when DW_AT_Associated => + return "associated"; + when DW_AT_Data_Location => + return "data_location"; + when DW_AT_Stride => + return "stride"; + when DW_AT_Entry_Pc => + return "entry_pc"; + when DW_AT_Use_UTF8 => + return "use_utf8"; + when DW_AT_Extension => + return "extension"; + when DW_AT_Ranges => + return "ranges"; + when DW_AT_Trampoline => + return "trampoline"; + when DW_AT_Call_Column => + return "call_column"; + when DW_AT_Call_File => + return "call_file"; + when DW_AT_Call_Line => + return "call_line"; + when DW_AT_Description => + return "description"; + when others => + return "unknown"; + end case; + end Get_Dwarf_At_Name; + + procedure Disp_Debug_Abbrev (File : Elf_File; Index : Elf_Half) + is + Shdr : Elf_Shdr_Acc; + Base : Address; + Old_Off : Storage_Offset; + Off : Storage_Offset; + V : Unsigned_32; + Tag : Unsigned_32; + Name : Unsigned_32; + Form : Unsigned_32; + begin + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Old_Off := Off; + Read_ULEB128 (Base, Off, V); + Put_Line ("abbrev #" & Hex_Image (V) & " at " + & Hex_Image (Unsigned_32 (Old_Off)) & ':'); + if V = 0 then + Put_Line ("pad"); + goto Again; + end if; + Read_ULEB128 (Base, Off, Tag); + Put (" tag: " & Hex_Image (Tag)); + Put (" ("); + Put (Get_Dwarf_Tag_Name (Tag)); + Put ("), children: " & Hex_Image (Read_Byte (Base + Off))); + New_Line; + Off := Off + 1; + loop + Read_ULEB128 (Base, Off, Name); + Read_ULEB128 (Base, Off, Form); + Put (" name: " & Hex_Image (Name)); + Put (" ("); + Put (Get_Dwarf_At_Name (Name)); + Put (")"); + Set_Col (42); + Put ("form: " & Hex_Image (Form)); + Put (" ("); + Put (Get_Dwarf_Form_Name (Form)); + Put (")"); + New_Line; + exit when Name = 0 and Form = 0; + end loop; + << Again >> null; + end loop; + end Disp_Debug_Abbrev; + + type Abbrev_Map_Type is array (Unsigned_32 range <>) of Address; + type Abbrev_Map_Acc is access Abbrev_Map_Type; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Abbrev_Map_Type, Abbrev_Map_Acc); + + procedure Build_Abbrev_Map (Base : Address; Res : out Abbrev_Map_Acc) + is + Max : Unsigned_32; + Off : Storage_Offset; + V : Unsigned_32; + V1 : Unsigned_32; + N_Res : Abbrev_Map_Acc; + begin + Off := 0; + Max := 0; + Res := new Abbrev_Map_Type (0 .. 128); + Res.all := (others => Null_Address); + loop + Read_ULEB128 (Base, Off, V); + if V > Max then + Max := V; + end if; + exit when V = 0; + if Max > Res.all'Last then + N_Res := new Abbrev_Map_Type (0 .. 2 * Max); + N_Res (Res'Range) := Res.all; + N_Res (Res'Last + 1 .. N_Res'Last) := (others => Null_Address); + Unchecked_Deallocation (Res); + Res := N_Res; + end if; + if Res (V) /= Null_Address then + Put_Line ("!! abbrev override !!"); + return; + end if; + Res (V) := Base + Off; + Read_ULEB128 (Base, Off, V); + -- Skip child flag. + Off := Off + 1; + loop + Read_ULEB128 (Base, Off, V); + Read_ULEB128 (Base, Off, V1); + exit when V = 0 and V1 = 0; + end loop; + end loop; + end Build_Abbrev_Map; + + procedure Disp_Block (Base : Address; + Off : in out Storage_Offset; + Cnt : Unsigned_32) + is + begin + for I in 1 .. Cnt loop + Put (" "); + Put (Hex_Image (Read_Byte (Base + Off + Storage_Offset (I - 1)))); + end loop; + Off := Off + Storage_Offset (Cnt); + end Disp_Block; + + procedure Disp_Dwarf_Form (Base : Address; + Off : in out Storage_Offset; + Form : Unsigned_32) + is + use Dwarf; + begin + case Form is + when DW_FORM_Addr => + declare + V : Unsigned_32; + begin + Read_Word4 (Base, Off, V); + Put ("address: " & Hex_Image (V)); + end; + when DW_FORM_Flag => + declare + V : Unsigned_8; + begin + Read_Byte (Base, Off, V); + Put ("flag: " & Hex_Image (V)); + end; + when DW_FORM_Block1 => + declare + V : Unsigned_8; + begin + Read_Byte (Base, Off, V); + Put ("block1: " & Hex_Image (V)); + Disp_Block (Base, Off, Unsigned_32 (V)); + end; + when DW_FORM_Data1 => + declare + V : Unsigned_8; + begin + Read_Byte (Base, Off, V); + Put ("data1: " & Hex_Image (V)); + end; + when DW_FORM_Data2 => + declare + V : Unsigned_16; + begin + Read_Word2 (Base, Off, V); + Put ("data2: " & Hex_Image (V)); + end; + when DW_FORM_Data4 => + declare + V : Unsigned_32; + begin + Read_Word4 (Base, Off, V); + Put ("data4: " & Hex_Image (V)); + end; + when DW_FORM_Sdata => + declare + V : Unsigned_32; + begin + Read_SLEB128 (Base, Off, V); + Put ("sdata: " & Hex_Image (V)); + end; + when DW_FORM_Udata => + declare + V : Unsigned_32; + begin + Read_ULEB128 (Base, Off, V); + Put ("udata: " & Hex_Image (V)); + end; + when DW_FORM_Ref4 => + declare + V : Unsigned_32; + begin + Read_Word4 (Base, Off, V); + Put ("ref4: " & Hex_Image (V)); + end; + when DW_FORM_Strp => + declare + V : Unsigned_32; + begin + Read_Word4 (Base, Off, V); + Put ("strp: " & Hex_Image (V)); + end; + when DW_FORM_String => + declare + C : Unsigned_8; + begin + Put ("string: "); + loop + Read_Byte (Base, Off, C); + exit when C = 0; + Put (Character'Val (C)); + end loop; + end; + when others => + Put ("???"); + raise Program_Error; + end case; + end Disp_Dwarf_Form; + + function Get_Dwarf_ATE_Name (Val : Unsigned_32) return String + is + use Dwarf; + begin + case Val is + when DW_ATE_Address => + return "address"; + when DW_ATE_Boolean => + return "boolean"; + when DW_ATE_Complex_Float => + return "complex_float"; + when DW_ATE_Float => + return "float"; + when DW_ATE_Signed => + return "signed"; + when DW_ATE_Signed_Char => + return "signed_char"; + when DW_ATE_Unsigned => + return "unsigned"; + when DW_ATE_Unsigned_Char => + return "unsigned_char"; + when DW_ATE_Imaginary_Float => + return "imaginary_float"; + when others => + return "unknown"; + end case; + end Get_Dwarf_ATE_Name; + + procedure Read_Dwarf_Constant (Base : Address; + Off : in out Storage_Offset; + Form : Unsigned_32; + Res : out Unsigned_32) + is + use Dwarf; + begin + case Form is + when DW_FORM_Data1 => + declare + V : Unsigned_8; + begin + Read_Byte (Base, Off, V); + Res := Unsigned_32 (V); + end; + when DW_FORM_Data2 => + declare + V : Unsigned_16; + begin + Read_Word2 (Base, Off, V); + Res := Unsigned_32 (V); + end; + when DW_FORM_Data4 => + declare + V : Unsigned_32; + begin + Read_Word4 (Base, Off, V); + Res := V; + end; + when DW_FORM_Sdata => + declare + V : Unsigned_32; + begin + Read_SLEB128 (Base, Off, V); + Res := V; + end; + when others => + raise Program_Error; + end case; + end Read_Dwarf_Constant; + + procedure Disp_Dwarf_Encoding + (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32) + is + Val : Unsigned_32; + begin + Read_Dwarf_Constant (Base, Off, Form, Val); + Put (Get_Dwarf_ATE_Name (Val)); + end Disp_Dwarf_Encoding; + + function Get_Dwarf_Lang_Name (Lang : Unsigned_32) return String + is + use Dwarf; + begin + case Lang is + when DW_LANG_C89 => + return "C89"; + when DW_LANG_C => + return "C"; + when DW_LANG_Ada83 => + return "Ada83"; + when DW_LANG_C_Plus_Plus => + return "C_Plus_Plus"; + when DW_LANG_Cobol74 => + return "Cobol74"; + when DW_LANG_Cobol85 => + return "Cobol85"; + when DW_LANG_Fortran77 => + return "Fortran77"; + when DW_LANG_Fortran90 => + return "Fortran90"; + when DW_LANG_Pascal83 => + return "Pascal83"; + when DW_LANG_Modula2 => + return "Modula2"; + when DW_LANG_Java => + return "Java"; + when DW_LANG_C99 => + return "C99"; + when DW_LANG_Ada95 => + return "Ada95"; + when DW_LANG_Fortran95 => + return "Fortran95"; + when DW_LANG_PLI => + return "PLI"; + when others => + return "?unknown?"; + end case; + end Get_Dwarf_Lang_Name; + + procedure Disp_Dwarf_Language + (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32) + is + Val : Unsigned_32; + begin + Read_Dwarf_Constant (Base, Off, Form, Val); + Put (Get_Dwarf_Lang_Name (Val)); + end Disp_Dwarf_Language; + + function Get_Dwarf_Op_Name (Op : Unsigned_8) return String + is + use Dwarf; + begin + case Op is + when DW_OP_Addr => + return "addr"; + when DW_OP_Deref => + return "deref"; + when DW_OP_Const1u => + return "const1u"; + when DW_OP_Const1s => + return "const1s"; + when DW_OP_Const2u => + return "const2u"; + when DW_OP_Const2s => + return "const2s"; + when DW_OP_Const4u => + return "const4u"; + when DW_OP_Const4s => + return "const4s"; + when DW_OP_Const8u => + return "const8u"; + when DW_OP_Const8s => + return "const8s"; + when DW_OP_Constu => + return "constu"; + when DW_OP_Consts => + return "consts"; + when DW_OP_Dup => + return "dup"; + when DW_OP_Drop => + return "drop"; + when DW_OP_Over => + return "over"; + when DW_OP_Pick => + return "pick"; + when DW_OP_Swap => + return "swap"; + when DW_OP_Rot => + return "rot"; + when DW_OP_Xderef => + return "xderef"; + when DW_OP_Abs => + return "abs"; + when DW_OP_And => + return "and"; + when DW_OP_Div => + return "div"; + when DW_OP_Minus => + return "minus"; + when DW_OP_Mod => + return "mod"; + when DW_OP_Mul => + return "mul"; + when DW_OP_Neg => + return "neg"; + when DW_OP_Not => + return "not"; + when DW_OP_Or => + return "or"; + when DW_OP_Plus => + return "plus"; + when DW_OP_Plus_Uconst => + return "plus_uconst"; + when DW_OP_Shl => + return "shl"; + when DW_OP_Shr => + return "shr"; + when DW_OP_Shra => + return "shra"; + when DW_OP_Xor => + return "xor"; + when DW_OP_Skip => + return "skip"; + when DW_OP_Bra => + return "bra"; + when DW_OP_Eq => + return "eq"; + when DW_OP_Ge => + return "ge"; + when DW_OP_Gt => + return "gt"; + when DW_OP_Le => + return "le"; + when DW_OP_Lt => + return "lt"; + when DW_OP_Ne => + return "ne"; + when DW_OP_Lit0 => + return "lit0"; + when DW_OP_Lit1 => + return "lit1"; + when DW_OP_Lit2 => + return "lit2"; + when DW_OP_Lit3 => + return "lit3"; + when DW_OP_Lit4 => + return "lit4"; + when DW_OP_Lit5 => + return "lit5"; + when DW_OP_Lit6 => + return "lit6"; + when DW_OP_Lit7 => + return "lit7"; + when DW_OP_Lit8 => + return "lit8"; + when DW_OP_Lit9 => + return "lit9"; + when DW_OP_Lit10 => + return "lit10"; + when DW_OP_Lit11 => + return "lit11"; + when DW_OP_Lit12 => + return "lit12"; + when DW_OP_Lit13 => + return "lit13"; + when DW_OP_Lit14 => + return "lit14"; + when DW_OP_Lit15 => + return "lit15"; + when DW_OP_Lit16 => + return "lit16"; + when DW_OP_Lit17 => + return "lit17"; + when DW_OP_Lit18 => + return "lit18"; + when DW_OP_Lit19 => + return "lit19"; + when DW_OP_Lit20 => + return "lit20"; + when DW_OP_Lit21 => + return "lit21"; + when DW_OP_Lit22 => + return "lit22"; + when DW_OP_Lit23 => + return "lit23"; + when DW_OP_Lit24 => + return "lit24"; + when DW_OP_Lit25 => + return "lit25"; + when DW_OP_Lit26 => + return "lit26"; + when DW_OP_Lit27 => + return "lit27"; + when DW_OP_Lit28 => + return "lit28"; + when DW_OP_Lit29 => + return "lit29"; + when DW_OP_Lit30 => + return "lit30"; + when DW_OP_Lit31 => + return "lit31"; + when DW_OP_Reg0 => + return "reg0"; + when DW_OP_Reg1 => + return "reg1"; + when DW_OP_Reg2 => + return "reg2"; + when DW_OP_Reg3 => + return "reg3"; + when DW_OP_Reg4 => + return "reg4"; + when DW_OP_Reg5 => + return "reg5"; + when DW_OP_Reg6 => + return "reg6"; + when DW_OP_Reg7 => + return "reg7"; + when DW_OP_Reg8 => + return "reg8"; + when DW_OP_Reg9 => + return "reg9"; + when DW_OP_Reg10 => + return "reg10"; + when DW_OP_Reg11 => + return "reg11"; + when DW_OP_Reg12 => + return "reg12"; + when DW_OP_Reg13 => + return "reg13"; + when DW_OP_Reg14 => + return "reg14"; + when DW_OP_Reg15 => + return "reg15"; + when DW_OP_Reg16 => + return "reg16"; + when DW_OP_Reg17 => + return "reg17"; + when DW_OP_Reg18 => + return "reg18"; + when DW_OP_Reg19 => + return "reg19"; + when DW_OP_Reg20 => + return "reg20"; + when DW_OP_Reg21 => + return "reg21"; + when DW_OP_Reg22 => + return "reg22"; + when DW_OP_Reg23 => + return "reg23"; + when DW_OP_Reg24 => + return "reg24"; + when DW_OP_Reg25 => + return "reg25"; + when DW_OP_Reg26 => + return "reg26"; + when DW_OP_Reg27 => + return "reg27"; + when DW_OP_Reg28 => + return "reg28"; + when DW_OP_Reg29 => + return "reg29"; + when DW_OP_Reg30 => + return "reg30"; + when DW_OP_Reg31 => + return "reg31"; + when DW_OP_Breg0 => + return "breg0"; + when DW_OP_Breg1 => + return "breg1"; + when DW_OP_Breg2 => + return "breg2"; + when DW_OP_Breg3 => + return "breg3"; + when DW_OP_Breg4 => + return "breg4"; + when DW_OP_Breg5 => + return "breg5"; + when DW_OP_Breg6 => + return "breg6"; + when DW_OP_Breg7 => + return "breg7"; + when DW_OP_Breg8 => + return "breg8"; + when DW_OP_Breg9 => + return "breg9"; + when DW_OP_Breg10 => + return "breg10"; + when DW_OP_Breg11 => + return "breg11"; + when DW_OP_Breg12 => + return "breg12"; + when DW_OP_Breg13 => + return "breg13"; + when DW_OP_Breg14 => + return "breg14"; + when DW_OP_Breg15 => + return "breg15"; + when DW_OP_Breg16 => + return "breg16"; + when DW_OP_Breg17 => + return "breg17"; + when DW_OP_Breg18 => + return "breg18"; + when DW_OP_Breg19 => + return "breg19"; + when DW_OP_Breg20 => + return "breg20"; + when DW_OP_Breg21 => + return "breg21"; + when DW_OP_Breg22 => + return "breg22"; + when DW_OP_Breg23 => + return "breg23"; + when DW_OP_Breg24 => + return "breg24"; + when DW_OP_Breg25 => + return "breg25"; + when DW_OP_Breg26 => + return "breg26"; + when DW_OP_Breg27 => + return "breg27"; + when DW_OP_Breg28 => + return "breg28"; + when DW_OP_Breg29 => + return "breg29"; + when DW_OP_Breg30 => + return "breg30"; + when DW_OP_Breg31 => + return "breg31"; + when DW_OP_Regx => + return "regx"; + when DW_OP_Fbreg => + return "fbreg"; + when DW_OP_Bregx => + return "bregx"; + when DW_OP_Piece => + return "piece"; + when DW_OP_Deref_Size => + return "deref_size"; + when DW_OP_Xderef_Size => + return "xderef_size"; + when DW_OP_Nop => + return "nop"; + when DW_OP_Push_Object_Address => + return "push_object_address"; + when DW_OP_Call2 => + return "call2"; + when DW_OP_Call4 => + return "call4"; + when DW_OP_Call_Ref => + return "call_ref"; + when others => + return "unknown"; + end case; + end Get_Dwarf_Op_Name; + + procedure Read_Dwarf_Block (Base : Address; + Off : in out Storage_Offset; + Form : Unsigned_32; + B : out Address; + L : out Unsigned_32) + is + use Dwarf; + begin + case Form is + when DW_FORM_Block1 => + B := Base + Off + 1; + L := Unsigned_32 (Read_Byte (Base + Off)); + Off := Off + 1; + when others => + raise Program_Error; + end case; + Off := Off + Storage_Offset (L); + end Read_Dwarf_Block; + + procedure Disp_Dwarf_Location + (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32) + is + use Dwarf; + B : Address; + L : Unsigned_32; + Op : Unsigned_8; + Boff : Storage_Offset; + Is_Full : Boolean; + begin + Read_Dwarf_Block (Base, Off, Form, B, L); + if L = 0 then + return; + end if; + Is_Full := L > 6; + Boff := 0; + while Boff < Storage_Offset (L) loop + if Is_Full then + New_Line; + Put (" "); + Put (Hex_Image (Unsigned_32 (Boff))); + Put (": "); + end if; + Op := Read_Byte (B + Boff); + Put (' '); + Put (Get_Dwarf_Op_Name (Op)); + Boff := Boff + 1; + case Op is + when DW_OP_Addr => + declare + V : Unsigned_32; + begin + Read_Word4 (B, Boff, V); + Put (':'); + Put (Hex_Image (V)); + end; + when DW_OP_Deref => + null; + when DW_OP_Const1u + | DW_OP_Const1s => + declare + V : Unsigned_8; + begin + Read_Byte (B, Boff, V); + Put (':'); + Put (Hex_Image (V)); + end; +-- DW_OP_Const2u : constant := 16#0a#; -- 1 2-byte constant +-- DW_OP_Const2s : constant := 16#0b#; -- 1 2-byte constant +-- DW_OP_Const4u : constant := 16#0c#; -- 1 4-byte constant +-- DW_OP_Const4s : constant := 16#0d#; -- 1 4-byte constant +-- DW_OP_Const8u : constant := 16#0e#; -- 1 8-byte constant +-- DW_OP_Const8s : constant := 16#0f#; -- 1 8-byte constant +-- DW_OP_Constu : constant := 16#10#; -- 1 ULEB128 constant +-- DW_OP_Consts : constant := 16#11#; -- 1 SLEB128 constant +-- DW_OP_Dup : constant := 16#12#; -- 0 +-- DW_OP_Drop : constant := 16#13#; -- 0 +-- DW_OP_Over : constant := 16#14#; -- 0 +-- DW_OP_Pick : constant := 16#15#; -- 1 1-byte stack index + + when DW_OP_Swap + | DW_OP_Rot + | DW_OP_Xderef + | DW_OP_Abs + | DW_OP_And + | DW_OP_Div + | DW_OP_Minus + | DW_OP_Mod + | DW_OP_Mul + | DW_OP_Neg + | DW_OP_Not + | DW_OP_Or + | DW_OP_Plus => + null; + when DW_OP_Plus_Uconst + | DW_OP_Piece + | DW_OP_Regx => + declare + V : Unsigned_32; + begin + Read_ULEB128 (B, Boff, V); + Put (':'); + Put (Hex_Image (V)); + end; + when DW_OP_Shl + | DW_OP_Shr + | DW_OP_Shra + | DW_OP_Xor => + null; + when DW_OP_Skip + | DW_OP_Bra => + declare + V : Unsigned_16; + begin + Read_Word2 (B, Boff, V); + Put (':'); + Put (Hex_Image (V)); + Put (" (@"); + -- FIXME: signed + Put (Hex_Image (Unsigned_32 (Boff) + Unsigned_32 (V))); + Put (")"); + end; + when DW_OP_Eq + | DW_OP_Ge + | DW_OP_Gt + | DW_OP_Le + | DW_OP_Lt + | DW_OP_Ne => + null; + when DW_OP_Lit0 .. DW_OP_Lit31 => + null; + when DW_OP_Reg0 .. DW_OP_Reg31 => + null; + when DW_OP_Breg0 .. DW_OP_Breg31 + | DW_OP_Fbreg => + declare + V : Unsigned_32; + begin + Read_SLEB128 (B, Boff, V); + Put (':'); + Put (Hex_Image (V)); + end; + +-- DW_OP_Regx : constant := 16#90#; -- 1 ULEB128 register +-- DW_OP_Bregx : constant := 16#92#; -- 2 ULEB128 reg + SLEB128 offset +-- DW_OP_Deref_Size : constant := 16#94#; -- 1 1-byte size of data retrieved +-- DW_OP_Xderef_Size : constant := 16#95#; -- 1 1-byte size of data retrieved + when DW_OP_Nop => + null; +-- DW_OP_Push_Object_Address : constant := 16#97#; -- 0 +-- DW_OP_Call2 : constant := 16#98#; -- 1 2-byte offset of DIE +-- DW_OP_Call4 : constant := 16#99#; -- 1 4-byte offset of DIE +-- DW_OP_Call_Ref : constant := 16#9a#; -- 1 4- or 8-byte offset of DIE + when others => + raise Program_Error; + end case; + end loop; + end Disp_Dwarf_Location; + + procedure Disp_Debug_Info (File : Elf_File; Index : Elf_Half) + is + use Dwarf; + + Abbrev_Index : Elf_Half; + Abbrev_Base : Address; + Map : Abbrev_Map_Acc; + Abbrev : Address; + + Shdr : Elf_Shdr_Acc; + Base : Address; + Off : Storage_Offset; + Aoff : Storage_Offset; + Old_Off : Storage_Offset; + + Len : Unsigned_32; + Ver : Unsigned_16; + Abbrev_Off : Unsigned_32; + Ptr_Sz : Unsigned_8; + Last : Storage_Offset; + Num : Unsigned_32; + + Tag : Unsigned_32; + Name : Unsigned_32; + Form : Unsigned_32; + + Level : Unsigned_8; + begin + Abbrev_Index := Get_Section_By_Name (File, ".debug_abbrev"); + Abbrev_Base := Get_Section_Base (File, Abbrev_Index); + Map := null; + + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Put_Line ("Compilation unit at #" + & Hex_Image (Unsigned_32 (Off)) & ":"); + Read_Word4 (Base, Off, Len); + Last := Off + Storage_Offset (Len); + Read_Word2 (Base, Off, Ver); + Read_Word4 (Base, Off, Abbrev_Off); + Read_Byte (Base, Off, Ptr_Sz); + Put (' '); + Put ("length: " & Hex_Image (Len)); + Put (", version: " & Hex_Image (Ver)); + Put (", abbrev offset: " & Hex_Image (Abbrev_Off)); + Put (", ptr_sz: " & Hex_Image (Ptr_Sz)); + New_Line; + Level := 0; + + Build_Abbrev_Map (Abbrev_Base + Storage_Offset (Abbrev_Off), Map); + loop + << Again >> null; + exit when Off >= Last; + Old_Off := Off; + Read_ULEB128 (Base, Off, Num); + Put ("<" & Hex_Image (Unsigned_32 (Old_Off)) & ">"); + Put ("<" & Hex_Image (Level) & ">"); + Put (" with abbrev #" & Hex_Image (Num)); + if Num = 0 then + Level := Level - 1; + New_Line; + goto Again; + end if; + if Num <= Map.all'Last then + Abbrev := Map (Num); + else + Abbrev := Null_Address; + end if; + if Abbrev = Null_Address then + New_Line; + Put ("!! abbrev #" & Hex_Image (Num) & " does not exist !!"); + New_Line; + return; + end if; + Aoff := 0; + Read_ULEB128 (Abbrev, Aoff, Tag); + if Read_Byte (Abbrev + Aoff) /= 0 then + Put (" [has_child]"); + Level := Level + 1; + end if; + New_Line; + + -- skip child. + Aoff := Aoff + 1; + Put (" tag: " & Hex_Image (Tag)); + Put (" ("); + Put (Get_Dwarf_Tag_Name (Tag)); + Put (")"); + New_Line; + + loop + Read_ULEB128 (Abbrev, Aoff, Name); + Read_ULEB128 (Abbrev, Aoff, Form); + exit when Name = 0 and Form = 0; + Put (" "); + Put (Get_Dwarf_At_Name (Name)); + Set_Col (24); + Put (": "); + Old_Off := Off; + Disp_Dwarf_Form (Base, Off, Form); + case Name is + when DW_AT_Encoding => + Put (": "); + Disp_Dwarf_Encoding (Base, Old_Off, Form); + when DW_AT_Location + | DW_AT_Frame_Base + | DW_AT_Data_Member_Location => + Put (":"); + Disp_Dwarf_Location (Base, Old_Off, Form); + when DW_AT_Language => + Put (": "); + Disp_Dwarf_Language (Base, Old_Off, Form); + when others => + null; + end case; + New_Line; + end loop; + end loop; + Unchecked_Deallocation (Map); + New_Line; + end loop; + end Disp_Debug_Info; + + function Get_Phdr_Type_Name (Ptype : Elf_Word) return String is + begin + case Ptype is + when PT_NULL => + return "NULL"; + when PT_LOAD => + return "LOAD"; + when PT_DYNAMIC => + return "DYNAMIC"; + when PT_INTERP => + return "INTERP"; + when PT_NOTE => + return "NOTE"; + when PT_SHLIB => + return "SHLIB"; + when PT_PHDR => + return "PHDR"; + when PT_TLS => + return "TLS"; + when PT_NUM => + return "NUM"; + when PT_GNU_EH_FRAME => + return "GNU_EH_FRAME"; + when PT_SUNWBSS => + return "SUNWBSS"; + when PT_SUNWSTACK => + return "SUNWSTACK"; + when others => + return "?unknown?"; + end case; + end Get_Phdr_Type_Name; + + procedure Disp_Phdr (Phdr : Elf_Phdr) + is + begin + Put ("type : " & Hex_Image (Phdr.P_Type)); + Put (" "); + Put (Get_Phdr_Type_Name (Phdr.P_Type)); + New_Line; + Put ("offset: " & Hex_Image (Phdr.P_Offset)); + Put (" vaddr: " & Hex_Image (Phdr.P_Vaddr)); + Put (" paddr: " & Hex_Image (Phdr.P_Paddr)); + New_Line; + Put ("filesz: " & Hex_Image (Phdr.P_Filesz)); + Put (" memsz: " & Hex_Image (Phdr.P_Memsz)); + Put (" align: " & Hex_Image (Phdr.P_Align)); + --New_Line; + Put (" flags: " & Hex_Image (Phdr.P_Flags)); + Put (" ("); + if (Phdr.P_Flags and PF_X) /= 0 then + Put ('X'); + end if; + if (Phdr.P_Flags and PF_W) /= 0 then + Put ('W'); + end if; + if (Phdr.P_Flags and PF_R) /= 0 then + Put ('R'); + end if; + Put (")"); + New_Line; + end Disp_Phdr; + + procedure Disp_Debug_Pubnames (File : Elf_File; Index : Elf_Half) + is + Shdr : Elf_Shdr_Acc; + Base : Address; + Off : Storage_Offset; + B : Unsigned_8; + + Len : Unsigned_32; + Ver : Unsigned_16; + Info_Off : Unsigned_32; + Info_Length : Unsigned_32; + Last : Storage_Offset; + Ioff : Unsigned_32; + begin + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Read_Word4 (Base, Off, Len); + Last := Off + Storage_Offset (Len); + Read_Word2 (Base, Off, Ver); + Read_Word4 (Base, Off, Info_Off); + Read_Word4 (Base, Off, Info_Length); + Put ("length: " & Hex_Image (Len)); + Put (", version: " & Hex_Image (Ver)); + Put (", offset: " & Hex_Image (Info_Off)); + Put (", length: " & Hex_Image (Info_Length)); + New_Line; + + loop + Read_Word4 (Base, Off, Ioff); + Put (" "); + Put (Hex_Image (Ioff)); + if Ioff /= 0 then + Put (": "); + loop + Read_Byte (Base, Off, B); + exit when B = 0; + Put (Character'Val (B)); + end loop; + end if; + New_Line; + exit when Ioff = 0; + end loop; + end loop; + end Disp_Debug_Pubnames; + + procedure Disp_Debug_Aranges (File : Elf_File; Index : Elf_Half) + is + Shdr : Elf_Shdr_Acc; + Base : Address; + Off : Storage_Offset; + + Set_Len : Unsigned_32; + Ver : Unsigned_16; + Info_Off : Unsigned_32; + Last : Storage_Offset; + Addr_Sz : Unsigned_8; + Seg_Sz : Unsigned_8; + Pad : Unsigned_32; + + Addr : Unsigned_32; + Len : Unsigned_32; + begin + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Read_Word4 (Base, Off, Set_Len); + Last := Off + Storage_Offset (Set_Len); + Read_Word2 (Base, Off, Ver); + Read_Word4 (Base, Off, Info_Off); + Read_Byte (Base, Off, Addr_Sz); + Read_Byte (Base, Off, Seg_Sz); + Read_Word4 (Base, Off, Pad); + Put ("length: " & Hex_Image (Set_Len)); + Put (", version: " & Hex_Image (Ver)); + Put (", offset: " & Hex_Image (Info_Off)); + Put (", ptr_sz: " & Hex_Image (Addr_Sz)); + Put (", seg_sz: " & Hex_Image (Seg_Sz)); + New_Line; + + loop + Read_Word4 (Base, Off, Addr); + Read_Word4 (Base, Off, Len); + Put (" "); + Put (Hex_Image (Addr)); + Put ('+'); + Put (Hex_Image (Len)); + New_Line; + exit when Addr = 0 and Len = 0; + end loop; + end loop; + end Disp_Debug_Aranges; + + procedure Disp_String (Base : Address; Off : in out Storage_Offset) + is + B : Unsigned_8; + begin + loop + B := Read_Byte (Base + Off); + Off := Off + 1; + exit when B = 0; + Put (Character'Val (B)); + end loop; + end Disp_String; + + procedure Read_String (Base : Address; Off : in out Storage_Offset) + is + B : Unsigned_8; + begin + loop + Read_Byte (Base, Off, B); + exit when B = 0; + end loop; + end Read_String; + + function Get_Dwarf_LNS_Name (Lns : Unsigned_8) return String + is + use Dwarf; + begin + case Lns is + when DW_LNS_Copy => + return "copy"; + when DW_LNS_Advance_Pc => + return "advance_pc"; + when DW_LNS_Advance_Line => + return "advance_line"; + when DW_LNS_Set_File => + return "set_file"; + when DW_LNS_Set_Column => + return "set_column"; + when DW_LNS_Negate_Stmt => + return "negate_stmt"; + when DW_LNS_Set_Basic_Block => + return "set_basic_block"; + when DW_LNS_Const_Add_Pc => + return "const_add_pc"; + when DW_LNS_Fixed_Advance_Pc => + return "fixed_advance_pc"; + when DW_LNS_Set_Prologue_End => + return "set_prologue_end"; + when DW_LNS_Set_Epilogue_Begin => + return "set_epilogue_begin"; + when DW_LNS_Set_Isa => + return "set_isa"; + when others => + return "?unknown?"; + end case; + end Get_Dwarf_LNS_Name; + + procedure Disp_Debug_Line (File : Elf_File; Index : Elf_Half) + is + use Dwarf; + Shdr : Elf_Shdr_Acc; + Base : Address; + Off : Storage_Offset; + + type Opc_Length_Type is array (Unsigned_8 range <>) of Unsigned_8; + type Opc_Length_Acc is access Opc_Length_Type; + Opc_Length : Opc_Length_Acc; + + 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; + + Old_Off : Storage_Offset; + File_Dir : Unsigned_32; + File_Time : Unsigned_32; + File_Len : Unsigned_32; + + Ext_Len : Unsigned_32; + Ext_Opc : Unsigned_8; + + Last : Storage_Offset; + + Pc : Unsigned_32; + Line : Unsigned_32; + Line_Base2 : Unsigned_32; + begin + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Read_Word4 (Base, Off, Total_Len); + Last := Off + Storage_Offset (Total_Len); + Read_Word2 (Base, Off, Version); + Read_Word4 (Base, Off, Prolog_Len); + Read_Byte (Base, Off, Min_Insn_Len); + Read_Byte (Base, Off, Dflt_Is_Stmt); + Read_Byte (Base, Off, Line_Base); + Read_Byte (Base, Off, Line_Range); + Read_Byte (Base, Off, Opc_Base); + + Pc := 0; + Line := 1; + + Put ("length: " & Hex_Image (Total_Len)); + Put (", version: " & Hex_Image (Version)); + Put (", prolog_len: " & Hex_Image (Prolog_Len)); + New_Line; + Put (" minimum_instruction_len: " & Hex_Image (Min_Insn_Len)); + Put (", default_is_stmt: " & Hex_Image (Dflt_Is_Stmt)); + New_Line; + Put (" line_base: " & Hex_Image (Line_Base)); + Put (", line_range: " & Hex_Image (Line_Range)); + Put (", opc_base: " & Hex_Image (Opc_Base)); + New_Line; + 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; + Put_Line ("standard_opcode_length:"); + Opc_Length := new Opc_Length_Type (1 .. Opc_Base - 1); + for I in 1 .. Opc_Base - 1 loop + Read_Byte (Base, Off, B); + Put (' '); + Put (Hex_Image (I)); + Put (" => "); + Put (Hex_Image (B)); + Opc_Length (I) := B; + New_Line; + end loop; + Put_Line ("include_directories:"); + loop + B := Read_Byte (Base + Off); + exit when B = 0; + Put (' '); + Disp_String (Base, Off); + New_Line; + end loop; + Off := Off + 1; + Put_Line ("file_names:"); + loop + B := Read_Byte (Base + Off); + exit when B = 0; + Old_Off := Off; + Read_String (Base, Off); + Read_ULEB128 (Base, Off, File_Dir); + Read_ULEB128 (Base, Off, File_Time); + Read_ULEB128 (Base, Off, File_Len); + Put (' '); + Put (Hex_Image (File_Dir)); + Put (' '); + Put (Hex_Image (File_Time)); + Put (' '); + Put (Hex_Image (File_Len)); + Put (' '); + Disp_String (Base, Old_Off); + New_Line; + end loop; + Off := Off + 1; + + while Off < Last loop + Put (" "); + Read_Byte (Base, Off, B); + Put (Hex_Image (B)); + Old_Off := Off; + if B < Opc_Base then + case B is + when 0 => + Put (" (extended)"); + Read_ULEB128 (Base, Off, Ext_Len); + Put (", len: "); + Put (Hex_Image (Ext_Len)); + Old_Off := Off; + Read_Byte (Base, Off, Ext_Opc); + Put (" opc:"); + Put (Hex_Image (Ext_Opc)); + Off := Old_Off + Storage_Offset (Ext_Len); + when others => + Put (" ("); + Put (Get_Dwarf_LNS_Name (B)); + Put (")"); + Set_Col (20); + for J in 1 .. Opc_Length (B) loop + Read_ULEB128 (Base, Off, Arg); + Put (" "); + Put (Hex_Image (Arg)); + end loop; + end case; + case B is + when DW_LNS_Copy => + Put (" pc="); + Put (Hex_Image (Pc)); + Put (", line="); + Put (Unsigned_32'Image (Line)); + when DW_LNS_Advance_Pc => + Read_ULEB128 (Base, Old_Off, Arg); + Pc := Pc + Arg * Unsigned_32 (Min_Insn_Len); + Put (" pc="); + Put (Hex_Image (Pc)); + when DW_LNS_Advance_Line => + Read_SLEB128 (Base, Old_Off, Arg); + Line := Line + Arg; + Put (" line="); + Put (Unsigned_32'Image (Line)); + when DW_LNS_Set_File => + null; + when DW_LNS_Set_Column => + null; + when DW_LNS_Negate_Stmt => + null; + when DW_LNS_Set_Basic_Block => + null; + when DW_LNS_Const_Add_Pc => + Pc := Pc + Unsigned_32 ((255 - Opc_Base) / Line_Range) + * Unsigned_32 (Min_Insn_Len); + Put (" pc="); + Put (Hex_Image (Pc)); + when others => + null; + end case; + New_Line; + else + B := B - Opc_Base; + Pc := Pc + Unsigned_32 (B / Line_Range) + * Unsigned_32 (Min_Insn_Len); + Line := Line + Line_Base2 + Unsigned_32 (B mod Line_Range); + Put (" pc="); + Put (Hex_Image (Pc)); + Put (", line="); + Put (Unsigned_32'Image (Line)); + New_Line; + end if; + end loop; + end loop; + end Disp_Debug_Line; + + function Get_Dwarf_Cfi_Name (Cfi : Unsigned_8) return String + is + use Dwarf; + begin + case Cfi is + when DW_CFA_Advance_Loc_Min .. DW_CFA_Advance_Loc_Max => + return "advance_loc"; + when DW_CFA_Offset_Min .. DW_CFA_Offset_Max => + return "offset"; + when DW_CFA_Restore_Min .. DW_CFA_Restore_Max => + return "restore"; + when DW_CFA_Nop => + return "nop"; + when DW_CFA_Set_Loc => + return "set_loc"; + when DW_CFA_Advance_Loc1 => + return "advance_loc1"; + when DW_CFA_Advance_Loc2 => + return "advance_loc2"; + when DW_CFA_Advance_Loc4 => + return "advance_loc4"; + when DW_CFA_Offset_Extended => + return "offset_extended"; + when DW_CFA_Restore_Extended => + return "restore_extended"; + when DW_CFA_Undefined => + return "undefined"; + when DW_CFA_Same_Value => + return "same_value"; + when DW_CFA_Register => + return "register"; + when DW_CFA_Remember_State => + return "remember_state"; + when DW_CFA_Restore_State => + return "restore_state"; + when DW_CFA_Def_Cfa => + return "def_cfa"; + when DW_CFA_Def_Cfa_Register => + return "def_cfa_register"; + when DW_CFA_Def_Cfa_Offset => + return "def_cfa_offset"; + when DW_CFA_Def_Cfa_Expression => + return "def_cfa_expression"; + when others => + return "?unknown?"; + end case; + end Get_Dwarf_Cfi_Name; + + procedure Disp_Cfi (Base : Address; Length : Storage_Count) + is + use Dwarf; + L : Storage_Offset; + Op : Unsigned_8; + Off : Unsigned_32; + Reg : Unsigned_32; + begin + L := 0; + while L < Length loop + Op := Read_Byte (Base + L); + Put (" "); + Put (Hex_Image (Op)); + Put (" "); + Put (Get_Dwarf_Cfi_Name (Op)); + Put (" "); + L := L + 1; + case Op is + when DW_CFA_Nop => + null; + when DW_CFA_Advance_Loc_Min .. DW_CFA_Advance_Loc_Max => + Put (Hex_Image (Op and 16#3f#)); + when DW_CFA_Offset_Min .. DW_CFA_Offset_Max => + Read_ULEB128 (Base, L, Off); + Put ("reg:"); + Put (Hex_Image (Op and 16#3f#)); + Put (", offset:"); + Put (Hex_Image (Off)); + when DW_CFA_Def_Cfa => + Read_ULEB128 (Base, L, Reg); + Read_ULEB128 (Base, L, Off); + Put ("reg:"); + Put (Hex_Image (Reg)); + Put (", offset:"); + Put (Hex_Image (Off)); + when DW_CFA_Def_Cfa_Offset => + Read_ULEB128 (Base, L, Off); + Put (Hex_Image (Off)); + when DW_CFA_Def_Cfa_Register => + Read_ULEB128 (Base, L, Reg); + Put ("reg:"); + Put (Hex_Image (Reg)); + when others => + Put ("?unknown?"); + New_Line; + exit; + end case; + New_Line; + end loop; + end Disp_Cfi; + + procedure Disp_Debug_Frame (File : Elf_File; Index : Elf_Half) + is + Shdr : Elf_Shdr_Acc; + Base : Address; + Off : Storage_Offset; + Old_Off : Storage_Offset; + + Length : Unsigned_32; + Cie_Id : Unsigned_32; + Version : Unsigned_8; + Augmentation : Unsigned_8; + Code_Align : Unsigned_32; + Data_Align : Unsigned_32; + Ret_Addr_Reg : Unsigned_8; + + Init_Loc : Unsigned_32; + Addr_Rng : Unsigned_32; + begin + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Read_Word4 (Base, Off, Length); + Old_Off := Off; + + Read_Word4 (Base, Off, Cie_Id); + if Cie_Id = 16#Ff_Ff_Ff_Ff# then + Read_Byte (Base, Off, Version); + Read_Byte (Base, Off, Augmentation); + Put ("length: "); + Put (Hex_Image (Length)); + Put (", CIE_id: "); + Put (Hex_Image (Cie_Id)); + Put (", version: "); + Put (Hex_Image (Version)); + if Augmentation /= 0 then + Put (" +augmentation"); + New_Line; + else + New_Line; + Read_ULEB128 (Base, Off, Code_Align); + Read_SLEB128 (Base, Off, Data_Align); + Read_Byte (Base, Off, Ret_Addr_Reg); + Put ("code_align: "); + Put (Hex_Image (Code_Align)); + Put (", data_align: "); + Put (Hex_Image (Data_Align)); + Put (", ret_addr_reg: "); + Put (Hex_Image (Ret_Addr_Reg)); + New_Line; + Put ("initial instructions:"); + New_Line; + Disp_Cfi (Base + Off, Old_Off + Storage_Offset (Length) - Off); + end if; + else + Read_Word4 (Base, Off, Init_Loc); + Read_Word4 (Base, Off, Addr_Rng); + Put ("length: "); + Put (Hex_Image (Length)); + Put (", CIE_pointer: "); + Put (Hex_Image (Cie_Id)); + Put (", address_range: "); + Put (Hex_Image (Init_Loc)); + Put ("-"); + Put (Hex_Image (Init_Loc + Addr_Rng)); + New_Line; + Put ("instructions:"); + New_Line; + Disp_Cfi (Base + Off, Old_Off + Storage_Offset (Length) - Off); + end if; + Off := Old_Off + Storage_Offset (Length); + end loop; + end Disp_Debug_Frame; + + procedure Read_Coded (Base : Address; + Offset : in out Storage_Offset; + Code : Unsigned_8; + Val : out Unsigned_32) + is + use Dwarf; + + V2 : Unsigned_16; + begin + if Code = DW_EH_PE_Omit then + return; + end if; + case Code and DW_EH_PE_Format_Mask is + when DW_EH_PE_Uleb128 => + Read_ULEB128 (Base, Offset, Val); + when DW_EH_PE_Udata2 => + Read_Word2 (Base, Offset, V2); + Val := Unsigned_32 (V2); + when DW_EH_PE_Udata4 => + Read_Word4 (Base, Offset, Val); + when DW_EH_PE_Sleb128 => + Read_SLEB128 (Base, Offset, Val); + when DW_EH_PE_Sdata2 => + Read_Word2 (Base, Offset, V2); + Val := Unsigned_32 (V2); + if (V2 and 16#80_00#) /= 0 then + Val := Val or 16#Ff_Ff_00_00#; + end if; + when DW_EH_PE_Sdata4 => + Read_Word4 (Base, Offset, Val); + when others => + raise Program_Error; + end case; + end Read_Coded; + + procedure Disp_Eh_Frame_Hdr (File : Elf_File; Index : Elf_Half) + is + Shdr : Elf_Shdr_Acc; + Base : Address; + Off : Storage_Offset; + + Version : Unsigned_8; + Eh_Frame_Ptr_Enc : Unsigned_8; + Fde_Count_Enc : Unsigned_8; + Table_Enc : Unsigned_8; + + Eh_Frame_Ptr : Unsigned_32; + Fde_Count : Unsigned_32; + + Loc : Unsigned_32; + Addr : Unsigned_32; + begin + Shdr := Get_Shdr (File, Index); + Base := Get_Section_Base (File, Shdr.all); + + Off := 0; + while Off < Storage_Offset (Shdr.Sh_Size) loop + Read_Byte (Base, Off, Version); + Read_Byte (Base, Off, Eh_Frame_Ptr_Enc); + Read_Byte (Base, Off, Fde_Count_Enc); + Read_Byte (Base, Off, Table_Enc); + Put ("version: "); + Put (Hex_Image (Version)); + Put (", encodings: ptr:"); + Put (Hex_Image (Eh_Frame_Ptr_Enc)); + Put (" count:"); + Put (Hex_Image (Fde_Count_Enc)); + Put (" table:"); + Put (Hex_Image (Table_Enc)); + New_Line; + Read_Coded (Base, Off, Eh_Frame_Ptr_Enc, Eh_Frame_Ptr); + Read_Coded (Base, Off, Fde_Count_Enc, Fde_Count); + Put ("eh_frame_ptr: "); + Put (Hex_Image (Eh_Frame_Ptr)); + Put (", fde_count: "); + Put (Hex_Image (Fde_Count)); + New_Line; + for I in 1 .. Fde_Count loop + Read_Coded (Base, Off, Table_Enc, Loc); + Read_Coded (Base, Off, Table_Enc, Addr); + Put (" init loc: "); + Put (Hex_Image (Loc)); + Put (", addr : "); + Put (Hex_Image (Addr)); + New_Line; + end loop; + end loop; + end Disp_Eh_Frame_Hdr; +end Elfdumper; diff --git a/ortho/mcode/elfdumper.ads b/ortho/mcode/elfdumper.ads new file mode 100644 index 0000000..0227f0f --- /dev/null +++ b/ortho/mcode/elfdumper.ads @@ -0,0 +1,164 @@ +-- ELF dumper (library). +-- 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 System; use System; +with Elf_Common; use Elf_Common; +with Elf_Arch; use Elf_Arch; +with Ada.Unchecked_Conversion; + +package Elfdumper is + procedure Disp_Ehdr (Ehdr : Elf_Ehdr); + + type Strtab_Fat_Type is array (Elf_Size) of Character; + type Strtab_Fat_Acc is access all Strtab_Fat_Type; + + type Strtab_Type is record + Base : Strtab_Fat_Acc; + Length : Elf_Size; + end record; + + Null_Strtab : constant Strtab_Type := (null, 0); + + Nul : constant Character := Character'Val (0); + + function Get_String (Strtab : Strtab_Type; N : Elf_Size) + return String; + + procedure Disp_Shdr (Shdr : Elf_Shdr; Sh_Strtab : Strtab_Type); + + type Elf_Shdr_Array is array (Elf_Half range <>) of Elf_Shdr; + + type Elf_File is limited private; + type Elf_File_Status is + ( + -- No error. + Status_Ok, + + -- Cannot open file. + Status_Open_Failure, + + Status_Bad_File, + Status_Memory, + Status_Read_Error, + Status_Bad_Magic, + Status_Bad_Class + ); + + procedure Open_File (File : out Elf_File; Filename : String); + + function Get_Status (File : Elf_File) return Elf_File_Status; + + type Elf_Ehdr_Acc is access all Elf_Ehdr; + + function Get_Ehdr (File : Elf_File) return Elf_Ehdr_Acc; + + procedure Load_Shdr (File : in out Elf_File); + + type Elf_Shdr_Acc is access all Elf_Shdr; + + function Get_Shdr (File : Elf_File; Index : Elf_Half) + return Elf_Shdr_Acc; + + function Get_Shdr_Type_Name (Stype : Elf_Word) return String; + + procedure Load_Phdr (File : in out Elf_File); + + type Elf_Phdr_Acc is access all Elf_Phdr; + + function Get_Phdr (File : Elf_File; Index : Elf_Half) + return Elf_Phdr_Acc; + + function Get_Segment_Base (File : Elf_File; Index : Elf_Half) + return Address; + + function Get_Sh_Strtab (File : Elf_File) return Strtab_Type; + + procedure Disp_Sym (File : Elf_File; + Sym : Elf_Sym; + Strtab : Strtab_Type); + + procedure Disp_Symtab (File : Elf_File; Index : Elf_Half); + procedure Disp_Strtab (File : Elf_File; Index : Elf_Half); + + function Get_Section_Name (File : Elf_File; Index : Elf_Half) + return String; + + function Get_Section_By_Name (File : Elf_File; Name : String) + return Elf_Half; + + procedure Disp_Debug_Abbrev (File : Elf_File; Index : Elf_Half); + procedure Disp_Debug_Info (File : Elf_File; Index : Elf_Half); + procedure Disp_Debug_Pubnames (File : Elf_File; Index : Elf_Half); + procedure Disp_Debug_Aranges (File : Elf_File; Index : Elf_Half); + procedure Disp_Debug_Line (File : Elf_File; Index : Elf_Half); + procedure Disp_Debug_Frame (File : Elf_File; Index : Elf_Half); + procedure Disp_Eh_Frame_Hdr (File : Elf_File; Index : Elf_Half); + + procedure Disp_Phdr (Phdr : Elf_Phdr); + + procedure Disp_Segment_Note (File : Elf_File; Index : Elf_Half); + procedure Disp_Section_Note (File : Elf_File; Index : Elf_Half); + + procedure Disp_Dynamic (File : Elf_File; Index : Elf_Half); +private + use System; + + function To_Strtab_Fat_Acc is new Ada.Unchecked_Conversion + (Address, Strtab_Fat_Acc); + + type String_Acc is access String; + + function To_Elf_Ehdr_Acc is new Ada.Unchecked_Conversion + (Address, Elf_Ehdr_Acc); + + function To_Elf_Phdr_Acc is new Ada.Unchecked_Conversion + (Address, Elf_Phdr_Acc); + + function To_Elf_Shdr_Acc is new Ada.Unchecked_Conversion + (Address, Elf_Shdr_Acc); + + type Elf_Sym_Acc is access all Elf_Sym; + function To_Elf_Sym_Acc is new Ada.Unchecked_Conversion + (Address, Elf_Sym_Acc); + + type Elf_Shdr_Arr is array (Elf_Half) of Elf_Shdr; + + type Elf_Shdr_Arr_Acc is access all Elf_Shdr_Arr; + function To_Elf_Shdr_Arr_Acc is new Ada.Unchecked_Conversion + (Address, Elf_Shdr_Arr_Acc); + + type Elf_File is record + -- Name of the file. + Filename : String_Acc; + + -- Status, used to report errors. + Status : Elf_File_Status; + + -- Length of the file. + Length : Elf_Off; + + -- File contents. + Base : Address; + + Ehdr : Elf_Ehdr_Acc; + + Shdr_Base : Address; + Sh_Strtab : Strtab_Type; + + Phdr_Base : Address; + end record; +end Elfdumper; diff --git a/ortho/mcode/hex_images.adb b/ortho/mcode/hex_images.adb new file mode 100644 index 0000000..a9dca32 --- /dev/null +++ b/ortho/mcode/hex_images.adb @@ -0,0 +1,71 @@ +-- To hexadecimal conversions. +-- 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 Ada.Unchecked_Conversion; + +package body Hex_Images is + type Hex_Str_Type is array (0 .. 15) of Character; + Hexdigits : constant Hex_Str_Type := "0123456789abcdef"; + + function Hex_Image (B : Unsigned_8) return String is + Res : String (1 .. 2); + begin + for I in 1 .. 2 loop + Res (I) := Hexdigits + (Natural (Shift_Right (B, 8 - 4 * I) and 16#0f#)); + end loop; + return Res; + end Hex_Image; + + function Conv is new Ada.Unchecked_Conversion + (Source => Integer_32, Target => Unsigned_32); + + function Hex_Image (W : Unsigned_32) return String is + Res : String (1 .. 8); + begin + for I in 1 .. 8 loop + Res (I) := Hexdigits + (Natural (Shift_Right (W, 32 - 4 * I) and 16#0f#)); + end loop; + return Res; + end Hex_Image; + + function Hex_Image (W : Unsigned_64) return String is + Res : String (1 .. 16); + begin + for I in 1 .. 16 loop + Res (I) := Hexdigits + (Natural (Shift_Right (W, 64 - 4 * I) and 16#0f#)); + end loop; + return Res; + end Hex_Image; + + function Hex_Image (W : Unsigned_16) return String is + Res : String (1 .. 4); + begin + for I in 1 .. 4 loop + Res (I) := Hexdigits + (Natural (Shift_Right (W, 16 - 4 * I) and 16#0f#)); + end loop; + return Res; + end Hex_Image; + + function Hex_Image (W : Integer_32) return String is + begin + return Hex_Image (Conv (W)); + end Hex_Image; +end Hex_Images; diff --git a/ortho/mcode/hex_images.ads b/ortho/mcode/hex_images.ads new file mode 100644 index 0000000..830d2ec --- /dev/null +++ b/ortho/mcode/hex_images.ads @@ -0,0 +1,26 @@ +-- To hexadecimal conversions. +-- 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 Interfaces; use Interfaces; + +package Hex_Images is + function Hex_Image (W : Integer_32) return String; + function Hex_Image (W : Unsigned_32) return String; + function Hex_Image (B : Unsigned_8) return String; + function Hex_Image (W : Unsigned_16) return String; + function Hex_Image (W : Unsigned_64) return String; +end Hex_Images; diff --git a/ortho/mcode/memsegs.ads b/ortho/mcode/memsegs.ads new file mode 100644 index 0000000..ff7f894 --- /dev/null +++ b/ortho/mcode/memsegs.ads @@ -0,0 +1,3 @@ +with Memsegs_Mmap; +package Memsegs renames Memsegs_Mmap; + diff --git a/ortho/mcode/memsegs_c.c b/ortho/mcode/memsegs_c.c new file mode 100644 index 0000000..a35d695 --- /dev/null +++ b/ortho/mcode/memsegs_c.c @@ -0,0 +1,116 @@ +/* Memory segment handling. + 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. +*/ +#ifndef WINNT + +#define _GNU_SOURCE +#include <sys/mman.h> +#include <stddef.h> +/* #include <stdio.h> */ + +/* TODO: init (get pagesize) + round size, + set rights. +*/ + +void * +mmap_malloc (int size) +{ + void *res; + res = mmap (NULL, size, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS, 0, 0); + /* printf ("mmap (%d) = %p\n", size, res); */ +#if 0 + if (res == MAP_FAILED) + return NULL; +#endif + return res; +} + +void * +mmap_realloc (void *ptr, int old_size, int size) +{ + void *res; + res = mremap (ptr, old_size, size, MREMAP_MAYMOVE); + /* printf ("mremap (%p, %d, %d) = %p\n", ptr, old_size, size, res); */ +#if 0 + if (res == MAP_FAILED) + return NULL; +#endif + return res; +} + +void +mmap_free (void * ptr, int size) +{ + munmap (ptr, size); +} + +void +mmap_rx (void *ptr, int size) +{ + mprotect (ptr, size, PROT_READ | PROT_EXEC); +} + +#else +#include <windows.h> + +void * +mmap_malloc (int size) +{ + void *res; + res = VirtualAlloc (NULL, size, + MEM_COMMIT | MEM_RESERVE, + PAGE_READWRITE); + return res; +} + +void * +mmap_realloc (void *ptr, int old_size, int size) +{ + void *res; + + res = VirtualAlloc (NULL, size, + MEM_COMMIT | MEM_RESERVE, + PAGE_READWRITE); + + if (ptr != NULL) + { + CopyMemory (res, ptr, size > old_size ? old_size : size); + VirtualFree (ptr, old_size, MEM_RELEASE); + } + + return res; +} + +void +mmap_free (void * ptr, int size) +{ + VirtualFree (ptr, size, MEM_RELEASE); +} + +void +mmap_rx (void *ptr, int size) +{ + DWORD old; + + /* This is not supported on every version. + In case of failure, this should still work. */ + VirtualProtect (ptr, size, PAGE_EXECUTE_READ, &old); +} +#endif diff --git a/ortho/mcode/memsegs_mmap.adb b/ortho/mcode/memsegs_mmap.adb new file mode 100644 index 0000000..1ee8e7b --- /dev/null +++ b/ortho/mcode/memsegs_mmap.adb @@ -0,0 +1,64 @@ +-- Memory segments. +-- 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. +package body Memsegs_Mmap is + function Mmap_Malloc (Size : Natural) return Address; + pragma Import (C, Mmap_Malloc, "mmap_malloc"); + + function Mmap_Realloc (Ptr : Address; Old_Size : Natural; Size : Natural) + return Address; + pragma Import (C, Mmap_Realloc, "mmap_realloc"); + + procedure Mmap_Free (Ptr : Address; Size : Natural); + pragma Import (C, Mmap_Free, "mmap_free"); + + procedure Mmap_Rx (Ptr : Address; Size : Natural); + pragma Import (C, Mmap_Rx, "mmap_rx"); + + function Create return Memseg_Type is + begin + return (Base => Null_Address, Size => 0); + end Create; + + procedure Resize (Seg : in out Memseg_Type; Size : Natural) is + begin + if Seg.Size = 0 then + Seg.Base := Mmap_Malloc (Size); + else + Seg.Base := Mmap_Realloc (Seg.Base, Seg.Size, Size); + end if; + Seg.Size := Size; + end Resize; + + function Get_Address (Seg : Memseg_Type) return Address is + begin + return Seg.Base; + end Get_Address; + + procedure Delete (Seg : in out Memseg_Type) is + begin + Mmap_Free (Seg.Base, Seg.Size); + Seg.Base := Null_Address; + Seg.Size := 0; + end Delete; + + procedure Set_Rx (Seg : in out Memseg_Type) is + begin + Mmap_Rx (Seg.Base, Seg.Size); + end Set_Rx; +end Memsegs_Mmap; + diff --git a/ortho/mcode/memsegs_mmap.ads b/ortho/mcode/memsegs_mmap.ads new file mode 100644 index 0000000..ba7d766 --- /dev/null +++ b/ortho/mcode/memsegs_mmap.ads @@ -0,0 +1,49 @@ +-- Memory segments. +-- 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 System; use System; + +package Memsegs_Mmap is + -- A memseg is a growable memory space. It can be resized with Resize. + -- After each operation the base address can change and must be get + -- with Get_Address. + type Memseg_Type is private; + + -- Create a new memseg. + function Create return Memseg_Type; + + -- Resize the memseg. + procedure Resize (Seg : in out Memseg_Type; Size : Natural); + + -- Get the base address. + function Get_Address (Seg : Memseg_Type) return Address; + + -- Free all the memory and initialize the memseg. + procedure Delete (Seg : in out Memseg_Type); + + -- Set the protection to read+execute. + procedure Set_Rx (Seg : in out Memseg_Type); + + pragma Inline (Create); + pragma Inline (Get_Address); +private + type Memseg_Type is record + Base : Address := Null_Address; + Size : Natural := 0; + end record; +end Memsegs_Mmap; + diff --git a/ortho/mcode/ortho_code-abi.ads b/ortho/mcode/ortho_code-abi.ads new file mode 100644 index 0000000..e75b085 --- /dev/null +++ b/ortho/mcode/ortho_code-abi.ads @@ -0,0 +1,3 @@ +with Ortho_Code.X86.Abi; + +package Ortho_Code.Abi renames Ortho_Code.X86.Abi; diff --git a/ortho/mcode/ortho_code-binary.adb b/ortho/mcode/ortho_code-binary.adb new file mode 100644 index 0000000..7bb6bdd --- /dev/null +++ b/ortho/mcode/ortho_code-binary.adb @@ -0,0 +1,37 @@ +-- Interface with binary writer for mcode. +-- 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 Ortho_Code.Decls; +with Ortho_Code.Exprs; + +package body Ortho_Code.Binary is + function Get_Decl_Symbol (Decl : O_Dnode) return Symbol + is + begin + return To_Symbol (Decls.Get_Decl_Info (Decl)); + end Get_Decl_Symbol; + + function Get_Label_Symbol (Label : O_Enode) return Symbol is + begin + return To_Symbol (Exprs.Get_Label_Info (Label)); + end Get_Label_Symbol; + + procedure Set_Label_Symbol (Label : O_Enode; Sym : Symbol) is + begin + Exprs.Set_Label_Info (Label, To_Int32 (Sym)); + end Set_Label_Symbol; +end Ortho_Code.Binary; diff --git a/ortho/mcode/ortho_code-binary.ads b/ortho/mcode/ortho_code-binary.ads new file mode 100644 index 0000000..58c79d3 --- /dev/null +++ b/ortho/mcode/ortho_code-binary.ads @@ -0,0 +1,31 @@ +-- Interface with binary writer for mcode. +-- 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 Binary_File; use Binary_File; + +package Ortho_Code.Binary is + function To_Symbol is new Ada.Unchecked_Conversion + (Source => Int32, Target => Symbol); + + function To_Int32 is new Ada.Unchecked_Conversion + (Source => Symbol, Target => Int32); + + function Get_Decl_Symbol (Decl : O_Dnode) return Symbol; + function Get_Label_Symbol (Label : O_Enode) return Symbol; + procedure Set_Label_Symbol (Label : O_Enode; Sym : Symbol); +end Ortho_Code.Binary; + diff --git a/ortho/mcode/ortho_code-consts.adb b/ortho/mcode/ortho_code-consts.adb new file mode 100644 index 0000000..2d3535d --- /dev/null +++ b/ortho/mcode/ortho_code-consts.adb @@ -0,0 +1,475 @@ +-- Mcode back-end for ortho - Constants handling. +-- 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 Ada.Unchecked_Conversion; +with GNAT.Table; +with Ada.Text_IO; +with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Debug; + +package body Ortho_Code.Consts is + type Cnode_Common is record + Kind : OC_Kind; + Lit_Type : O_Tnode; + end record; + + type Cnode_Signed is record + Val : Integer_64; + end record; + + type Cnode_Unsigned is record + Val : Unsigned_64; + end record; + + type Cnode_Float is record + Val : IEEE_Float_64; + end record; + + type Cnode_Enum is record + Id : O_Ident; + Val : Uns32; + end record; + + type Cnode_Addr is record + Decl : O_Dnode; + Pad : Int32; + end record; + + type Cnode_Aggr is record + Els : Int32; + Nbr : Int32; + end record; + + type Cnode_Sizeof is record + Atype : O_Tnode; + Pad : Int32; + end record; + + package Cnodes is new GNAT.Table + (Table_Component_Type => Cnode_Common, + Table_Index_Type => O_Cnode, + Table_Low_Bound => 2, + Table_Initial => 128, + Table_Increment => 100); + + function Get_Const_Kind (Cst : O_Cnode) return OC_Kind is + begin + return Cnodes.Table (Cst).Kind; + end Get_Const_Kind; + + function Get_Const_Type (Cst : O_Cnode) return O_Tnode is + begin + return Cnodes.Table (Cst).Lit_Type; + end Get_Const_Type; + + function Get_Const_U64 (Cst : O_Cnode) return Unsigned_64 + is + function To_Cnode_Unsigned is new Ada.Unchecked_Conversion + (Cnode_Common, Cnode_Unsigned); + begin + return To_Cnode_Unsigned (Cnodes.Table (Cst + 1)).Val; + end Get_Const_U64; + + function Get_Const_I64 (Cst : O_Cnode) return Integer_64 + is + function To_Cnode_Signed is new Ada.Unchecked_Conversion + (Cnode_Common, Cnode_Signed); + begin + return To_Cnode_Signed (Cnodes.Table (Cst + 1)).Val; + end Get_Const_I64; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Signed, Target => Cnode_Common); + + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Signed, + Lit_Type => Ltype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Signed'(Val => Value))); + return Res; + end New_Signed_Literal; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Unsigned, Target => Cnode_Common); + + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Unsigned, + Lit_Type => Ltype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Unsigned'(Val => Value))); + return Res; + end New_Unsigned_Literal; + +-- function Get_Const_Literal (Cst : O_Cnode) return Uns32 is +-- begin +-- return Cnodes.Table (Cst).Val; +-- end Get_Const_Literal; + + function To_Uns64 is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Uns64); + + function Get_Const_U32 (Cst : O_Cnode) return Uns32 is + begin + return Uns32 (To_Uns64 (Cnodes.Table (Cst + 1))); + end Get_Const_U32; + + function Get_Const_R64 (Cst : O_Cnode) return Uns64 is + begin + return To_Uns64 (Cnodes.Table (Cst + 1)); + end Get_Const_R64; + + function Get_Const_Low (Cst : O_Cnode) return Uns32 + is + V : Uns64; + begin + V := Get_Const_R64 (Cst); + return Uns32 (V and 16#Ffff_Ffff#); + end Get_Const_Low; + + function Get_Const_High (Cst : O_Cnode) return Uns32 + is + V : Uns64; + begin + V := Get_Const_R64 (Cst); + return Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#); + end Get_Const_High; + + function Get_Const_Low (Cst : O_Cnode) return Int32 + is + V : Uns64; + begin + V := Get_Const_R64 (Cst); + return To_Int32 (Uns32 (V and 16#Ffff_Ffff#)); + end Get_Const_Low; + + function Get_Const_High (Cst : O_Cnode) return Int32 + is + V : Uns64; + begin + V := Get_Const_R64 (Cst); + return To_Int32 (Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#)); + end Get_Const_High; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Float, Target => Cnode_Common); + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Float, + Lit_Type => Ltype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Float'(Val => Value))); + return Res; + end New_Float_Literal; + + function New_Null_Access (Ltype : O_Tnode) return O_Cnode is + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Null, + Lit_Type => Ltype)); + return Cnodes.Last; + end New_Null_Access; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Addr, Target => Cnode_Common); + + function To_Cnode_Addr is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Addr); + + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Address, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, + Pad => 0))); + return Res; + end New_Global_Unchecked_Address; + + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Address, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl, + Pad => 0))); + return Res; + end New_Global_Address; + + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Subprg_Address, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Subprg, + Pad => 0))); + return Res; + end New_Subprogram_Address; + + function Get_Const_Decl (Cst : O_Cnode) return O_Dnode is + begin + return To_Cnode_Addr (Cnodes.Table (Cst + 1)).Decl; + end Get_Const_Decl; + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Enum, Target => Cnode_Common); + + function To_Cnode_Enum is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Enum); + + --function Get_Named_Literal_Id (Lit : O_Cnode) return O_Ident is + --begin + -- return To_Cnode_Enum (Cnodes.Table (Lit + 1)).Id; + --end Get_Named_Literal_Id; + + function New_Named_Literal + (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode) + return O_Cnode + is + Res : O_Cnode; + begin + Cnodes.Append (Cnode_Common'(Kind => OC_Lit, + Lit_Type => Atype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Enum'(Id => Id, + Val => Val))); + if Prev /= O_Cnode_Null then + if Prev + 2 /= Res then + raise Syntax_Error; + end if; + end if; + return Res; + end New_Named_Literal; + + function Get_Lit_Ident (L : O_Cnode) return O_Ident is + begin + return To_Cnode_Enum (Cnodes.Table (L + 1)).Id; + end Get_Lit_Ident; + + function Get_Lit_Value (L : O_Cnode) return Uns32 is + begin + return To_Cnode_Enum (Cnodes.Table (L + 1)).Val; + end Get_Lit_Value; + + function Get_Lit_Chain (L : O_Cnode) return O_Cnode is + begin + return L + 2; + end Get_Lit_Chain; + + package Els is new GNAT.Table + (Table_Component_Type => O_Cnode, + Table_Index_Type => Int32, + Table_Low_Bound => 2, + Table_Initial => 128, + Table_Increment => 100); + + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Aggr, Target => Cnode_Common); + + function To_Cnode_Aggr is new Ada.Unchecked_Conversion + (Source => Cnode_Common, Target => Cnode_Aggr); + + + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; + Atype : O_Tnode) + is + Val : Int32; + Num : Uns32; + begin + Num := Get_Type_Record_Nbr_Fields (Atype); + Val := Els.Allocate (Integer (Num)); + + Cnodes.Append (Cnode_Common'(Kind => OC_Record, + Lit_Type => Atype)); + List := (Res => Cnodes.Last, + Rec_Field => Get_Type_Record_Fields (Atype), + El => Val); + Cnodes.Append (To_Cnode_Common (Cnode_Aggr'(Els => Val, + Nbr => Int32 (Num)))); + end Start_Record_Aggr; + + + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode) + is + begin + Els.Table (List.El) := Value; + List.El := List.El + 1; + end New_Record_Aggr_El; + + procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; + Res : out O_Cnode) is + begin + Res := List.Res; + end Finish_Record_Aggr; + + + procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) + is + Val : Int32; + Num : Uns32; + begin + Num := Get_Type_Subarray_Length (Atype); + Val := Els.Allocate (Integer (Num)); + + Cnodes.Append (Cnode_Common'(Kind => OC_Array, + Lit_Type => Atype)); + List := (Res => Cnodes.Last, + El => Val); + Cnodes.Append (To_Cnode_Common (Cnode_Aggr'(Els => Val, + Nbr => Int32 (Num)))); + end Start_Array_Aggr; + + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode) + is + begin + Els.Table (List.El) := Value; + List.El := List.El + 1; + end New_Array_Aggr_El; + + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode) + is + begin + Res := List.Res; + end Finish_Array_Aggr; + + function Get_Const_Aggr_Length (Cst : O_Cnode) return Int32 is + begin + return To_Cnode_Aggr (Cnodes.Table (Cst + 1)).Nbr; + end Get_Const_Aggr_Length; + + function Get_Const_Aggr_Element (Cst : O_Cnode; N : Int32) return O_Cnode + is + El : Int32; + begin + El := To_Cnode_Aggr (Cnodes.Table (Cst + 1)).Els; + return Els.Table (El + N); + end Get_Const_Aggr_Element; + + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode + is + pragma Unreferenced (Atype); + pragma Unreferenced (Field); + begin + return Value; + end New_Union_Aggr; + + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode + is + function To_Cnode_Common is new Ada.Unchecked_Conversion + (Source => Cnode_Sizeof, Target => Cnode_Common); + + Res : O_Cnode; + begin + if Debug.Flag_Debug_Hli then + Cnodes.Append (Cnode_Common'(Kind => OC_Sizeof, + Lit_Type => Rtype)); + Res := Cnodes.Last; + Cnodes.Append (To_Cnode_Common (Cnode_Sizeof'(Atype => Atype, + Pad => 0))); + return Res; + else + return New_Unsigned_Literal + (Rtype, Unsigned_64 (Get_Type_Size (Atype))); + end if; + end New_Sizeof; + + function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode + is + function To_Cnode_Sizeof is new Ada.Unchecked_Conversion + (Cnode_Common, Cnode_Sizeof); + begin + return To_Cnode_Sizeof (Cnodes.Table (Cst + 1)).Atype; + end Get_Sizeof_Type; + + function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode is + begin + return New_Unsigned_Literal + (Rtype, Unsigned_64 (Get_Field_Offset (Field))); + end New_Offsetof; + + procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32) is + begin + case Get_Const_Kind (Cst) is + when OC_Signed + | OC_Unsigned + | OC_Float => + H := Get_Const_High (Cst); + L := Get_Const_Low (Cst); + when OC_Null => + H := 0; + L := 0; + when OC_Lit => + H := 0; + L := To_Cnode_Enum (Cnodes.Table (Cst + 1)).Val; + when OC_Array + | OC_Record + | OC_Sizeof + | OC_Address + | OC_Subprg_Address => + raise Syntax_Error; + end case; + end Get_Const_Bytes; + + procedure Mark (M : out Mark_Type) is + begin + M.Cnode := Cnodes.Last; + M.Els := Els.Last; + end Mark; + + procedure Release (M : Mark_Type) is + begin + Cnodes.Set_Last (M.Cnode); + Els.Set_Last (M.Els); + end Release; + + procedure Disp_Stats + is + use Ada.Text_IO; + begin + Put_Line ("Number of Cnodes: " & O_Cnode'Image (Cnodes.Last)); + Put_Line ("Number of Cnodes-Els: " & Int32'Image (Els.Last)); + end Disp_Stats; + + procedure Finish is + begin + Cnodes.Free; + Els.Free; + end Finish; +end Ortho_Code.Consts; diff --git a/ortho/mcode/ortho_code-consts.ads b/ortho/mcode/ortho_code-consts.ads new file mode 100644 index 0000000..d83b916 --- /dev/null +++ b/ortho/mcode/ortho_code-consts.ads @@ -0,0 +1,143 @@ +-- Mcode back-end for ortho - Constants handling. +-- 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 Interfaces; use Interfaces; + +package Ortho_Code.Consts is + type OC_Kind is (OC_Signed, OC_Unsigned, OC_Float, OC_Lit, OC_Null, + OC_Array, OC_Record, OC_Subprg_Address, OC_Address, + OC_Sizeof); + + function Get_Const_Kind (Cst : O_Cnode) return OC_Kind; + + function Get_Const_Type (Cst : O_Cnode) return O_Tnode; + + -- Get bytes for signed, unsigned, float, lit, null. + procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32); + + -- Used to set the length of a constrained type. + -- FIXME: check for no overflow. + function Get_Const_U32 (Cst : O_Cnode) return Uns32; + + function Get_Const_U64 (Cst : O_Cnode) return Unsigned_64; + function Get_Const_I64 (Cst : O_Cnode) return Integer_64; + + -- Get the low and high part of a constant. + function Get_Const_Low (Cst : O_Cnode) return Uns32; + function Get_Const_High (Cst : O_Cnode) return Uns32; + + function Get_Const_Low (Cst : O_Cnode) return Int32; + function Get_Const_High (Cst : O_Cnode) return Int32; + + function Get_Const_Aggr_Length (Cst : O_Cnode) return Int32; + function Get_Const_Aggr_Element (Cst : O_Cnode; N : Int32) return O_Cnode; + + -- Declaration for an address. + function Get_Const_Decl (Cst : O_Cnode) return O_Dnode; + + -- Get the type whose size is expected. + function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode; + + -- Get the value of a named literal. + --function Get_Const_Literal (Cst : O_Cnode) return Uns32; + + -- Create a literal from an integer. + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode; + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode; + + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode; + + -- Create a null access literal. + function New_Null_Access (Ltype : O_Tnode) return O_Cnode; + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode; + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode; + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode; + + function New_Named_Literal + (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode) + return O_Cnode; + + -- For boolean/enum literals. + function Get_Lit_Ident (L : O_Cnode) return O_Ident; + function Get_Lit_Chain (L : O_Cnode) return O_Cnode; + function Get_Lit_Value (L : O_Cnode) return Uns32; + + type O_Record_Aggr_List is limited private; + type O_Array_Aggr_List is limited private; + + -- Build a record/array aggregate. + -- The aggregate is constant, and therefore can be only used to initialize + -- constant declaration. + -- ATYPE must be either a record type or an array subtype. + -- Elements must be added in the order, and must be literals or aggregates. + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; + Atype : O_Tnode); + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode); + procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; + Res : out O_Cnode); + + procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode); + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode); + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode); + + -- Build an union aggregate. + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode; + + -- Returns the size in bytes of ATYPE. The result is a literal of + -- unsigned type RTYPE + -- ATYPE cannot be an unconstrained array type. + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode; + + -- Returns the offset of FIELD in its record. The result is a literal + -- of unsigned type RTYPE. + function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode; + + procedure Disp_Stats; + + type Mark_Type is limited private; + procedure Mark (M : out Mark_Type); + procedure Release (M : Mark_Type); + + procedure Finish; +private + type O_Array_Aggr_List is record + Res : O_Cnode; + El : Int32; + end record; + + type O_Record_Aggr_List is record + Res : O_Cnode; + Rec_Field : O_Fnode; + El : Int32; + end record; + + type Mark_Type is record + Cnode : O_Cnode; + Els : Int32; + end record; + +end Ortho_Code.Consts; diff --git a/ortho/mcode/ortho_code-debug.adb b/ortho/mcode/ortho_code-debug.adb new file mode 100644 index 0000000..090298a --- /dev/null +++ b/ortho/mcode/ortho_code-debug.adb @@ -0,0 +1,141 @@ +-- Mcode back-end for ortho - Internal debugging. +-- 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 Ortho_Code.Flags; + +package body Ortho_Code.Debug is + procedure Disp_Mode (M : Mode_Type) + is + use Ada.Text_IO; + begin + case M is + when Mode_U8 => + Put ("U8 "); + when Mode_U16 => + Put ("U16"); + when Mode_U32 => + Put ("U32"); + when Mode_U64 => + Put ("U64"); + when Mode_I8 => + Put ("I8 "); + when Mode_I16 => + Put ("I16"); + when Mode_I32 => + Put ("I32"); + when Mode_I64 => + Put ("I64"); + when Mode_X1 => + Put ("xxx"); + when Mode_Nil => + Put ("Nil"); + when Mode_F32 => + Put ("F32"); + when Mode_F64 => + Put ("F64"); + when Mode_B2 => + Put ("B2 "); + when Mode_Blk => + Put ("Blk"); + when Mode_P32 => + Put ("P32"); + when Mode_P64 => + Put ("P64"); + end case; + end Disp_Mode; + + procedure Set_Debug_Be_Flag (C : Character) + is + use Ada.Text_IO; + begin + case C is + when 'a' => + Flag_Debug_Asm := True; + when 'b' => + Flag_Debug_Body := True; + when 'B' => + Flag_Debug_Body2 := True; + when 'c' => + Flag_Debug_Code := True; + when 'C' => + Flag_Debug_Code2 := True; + when 'd' => + Flag_Debug_Dump := True; + when 'h' => + Flag_Debug_Hex := True; + when 'H' => + Flag_Debug_Hli := True; + when 'i' => + Flag_Debug_Insn := True; + when 's' => + Flag_Debug_Stat := True; + when 'k' => + Flag_Debug_Keep := True; + when others => + Put_Line (Standard_Error, "unknown debug be flag '" & C & "'"); + end case; + end Set_Debug_Be_Flag; + + procedure Set_Be_Flag (Str : String) + is + use Ada.Text_IO; + + subtype Str_Type is String (1 .. Str'Length); + S : Str_Type renames Str; + begin + if S'Length > 11 and then S (1 .. 11) = "--be-debug=" then + for I in 12 .. S'Last loop + Set_Debug_Be_Flag (S (I)); + end loop; + elsif S'Length > 10 and then S (1 .. 10) = "--be-dump=" then + for I in 11 .. S'Last loop + case S (I) is + when 'c' => + Flag_Dump_Code := True; + when others => + Put_Line (Standard_Error, + "unknown back-end dump flag '" & S (I) & "'"); + end case; + end loop; + elsif S'Length > 10 and then S (1 .. 10) = "--be-disp=" then + for I in 11 .. S'Last loop + case S (I) is + when 'c' => + Flag_Disp_Code := True; + Flags.Flag_Type_Name := True; + when others => + Put_Line (Standard_Error, + "unknown back-end disp flag '" & S (I) & "'"); + end case; + end loop; + elsif S'Length > 9 and then S (1 .. 9) = "--be-opt=" then + for I in 10 .. S'Last loop + case S (I) is + when 'O' => + Flags.Flag_Optimize := True; + when 'b' => + Flags.Flag_Opt_BB := True; + when others => + Put_Line (Standard_Error, + "unknown back-end opt flag '" & S (I) & "'"); + end case; + end loop; + else + Put_Line (Standard_Error, "unknown back-end option " & Str); + end if; + end Set_Be_Flag; +end Ortho_Code.Debug; diff --git a/ortho/mcode/ortho_code-debug.ads b/ortho/mcode/ortho_code-debug.ads new file mode 100644 index 0000000..03f550a --- /dev/null +++ b/ortho/mcode/ortho_code-debug.ads @@ -0,0 +1,70 @@ +-- Mcode back-end for ortho - Internal debugging. +-- 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 Ada.Text_IO; + +package Ortho_Code.Debug is + package Int32_IO is new Ada.Text_IO.Integer_IO (Ortho_Code.Int32); + + procedure Disp_Mode (M : Mode_Type); + + -- Set a debug flag. + procedure Set_Debug_Be_Flag (C : Character); + + -- any '--be-XXX=YY' option. + procedure Set_Be_Flag (Str : String); + + -- c: tree created, before any back-end. + Flag_Disp_Code : Boolean := False; + Flag_Dump_Code : Boolean := False; + + -- a: disp assembly code. + Flag_Debug_Asm : Boolean := False; + + -- A: do internal checks (assertions). + Flag_Debug_Assert : Boolean := True; + + -- b: disp top-level subprogram body before code generation. + Flag_Debug_Body : Boolean := False; + + -- B: disp top-level subprogram body after code generation. + Flag_Debug_Body2 : Boolean := False; + + -- c: display generated code. + Flag_Debug_Code : Boolean := False; + + -- C: display generated code just before asm. + Flag_Debug_Code2 : Boolean := False; + + -- h: disp bytes generated (in hexa). + Flag_Debug_Hex : Boolean := False; + + -- H: generate high-level instructions. + Flag_Debug_Hli : Boolean := False; + + -- r: raw dump, do not generate code. + Flag_Debug_Dump : Boolean := False; + + -- i: disp insns, when generated. + Flag_Debug_Insn : Boolean := False; + + -- s: disp stats (number of nodes). + Flag_Debug_Stat : Boolean := False; + + -- k: keep all nodes in memory (do not free). + Flag_Debug_Keep: Boolean := False; +end Ortho_Code.Debug; diff --git a/ortho/mcode/ortho_code-decls.adb b/ortho/mcode/ortho_code-decls.adb new file mode 100644 index 0000000..44a2595 --- /dev/null +++ b/ortho/mcode/ortho_code-decls.adb @@ -0,0 +1,754 @@ +-- Mcode back-end for ortho - Declarations handling. +-- 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.Table; +with Ada.Text_IO; +with Ortho_Ident; +with Ortho_Code.Debug; use Ortho_Code.Debug; +with Ortho_Code.Exprs; +with Ortho_Code.Abi; use Ortho_Code.Abi; +with Ortho_Code.Flags; + +package body Ortho_Code.Decls is + -- Common fields: + -- kind: 4 bits + -- storage: 2 bits + -- reg : 8 bits + -- depth : 16 bits + -- flags: addr + 9 + -- Additionnal fields: + -- OD_Type: Id, dtype + -- OD_Var: Id, Dtype, symbol + -- OD_Local: Id, Dtype, offset/reg + -- OD_Const: Id, Dtype, Val, Symbol? + -- OD_Function: Id, Dtype [interfaces follows], Symbol + -- OD_Procedure: Id [interfaces follows], Symbol + -- OD_Interface: Id, Dtype, offset/reg + -- OD_Begin: Last + -- OD_Body: Decl, Stmt, Parent + type Dnode_Common (Kind : OD_Kind := OD_Type) is record + Storage : O_Storage; + + -- True if the address of the declaration is taken. + Flag_Addr : Boolean; + + Flag2 : Boolean; + + Reg : O_Reg; + + -- Depth of the declaration. + Depth : O_Depth; + + case Kind is + when OD_Type + | OD_Const + | OD_Var + | OD_Local + | OD_Function + | OD_Procedure + | OD_Interface => + -- Identifier of this declaration. + Id : O_Ident; + -- Type of this declaration. + Dtype : O_Tnode; + -- Symbol or offset. + Ref : Int32; + -- For const: the value. + -- For subprg: size of pushed arguments. + Info2 : Int32; + when OD_Block => + -- Last declaration of this block. + Last : O_Dnode; + -- Max stack offset. + Block_Max_Stack : Uns32; + -- Infos: may be used to store symbols. + Block_Info1 : Int32; + Block_Info2 : Int32; + when OD_Body => + -- Corresponding declaration (function/procedure). + Body_Decl : O_Dnode; + -- Entry statement for this body. + Body_Stmt : O_Enode; + -- Parent (as a body) of this body or null if at top level. + Body_Parent : O_Dnode; + Body_Info : Int32; + when OD_Const_Val => + -- Corresponding declaration. + Val_Decl : O_Dnode; + -- Value. + Val_Val : O_Cnode; + end case; + end record; + + pragma Pack (Dnode_Common); + + package Dnodes is new GNAT.Table + (Table_Component_Type => Dnode_Common, + Table_Index_Type => O_Dnode, + Table_Low_Bound => O_Dnode_First, + Table_Initial => 128, + Table_Increment => 100); + + package TDnodes is new GNAT.Table + (Table_Component_Type => O_Dnode, + Table_Index_Type => O_Tnode, + Table_Low_Bound => O_Tnode_First, + Table_Initial => 1, + Table_Increment => 100); + + Context : O_Dnode := O_Dnode_Null; + + function Get_Decl_Type (Decl : O_Dnode) return O_Tnode is + begin + return Dnodes.Table (Decl).Dtype; + end Get_Decl_Type; + + function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind is + begin + return Dnodes.Table (Decl).Kind; + end Get_Decl_Kind; + + function Get_Decl_Storage (Decl : O_Dnode) return O_Storage is + begin + return Dnodes.Table (Decl).Storage; + end Get_Decl_Storage; + + procedure Set_Decl_Storage (Decl : O_Dnode; Storage : O_Storage) is + begin + Dnodes.Table (Decl).Storage := Storage; + end Set_Decl_Storage; + + function Get_Decl_Reg (Decl : O_Dnode) return O_Reg is + begin + return Dnodes.Table (Decl).Reg; + end Get_Decl_Reg; + + procedure Set_Decl_Reg (Decl : O_Dnode; Reg : O_Reg) is + begin + Dnodes.Table (Decl).Reg := Reg; + end Set_Decl_Reg; + + function Get_Decl_Depth (Decl : O_Dnode) return O_Depth is + begin + return Dnodes.Table (Decl).Depth; + end Get_Decl_Depth; + + function Get_Decl_Chain (Decl : O_Dnode) return O_Dnode is + begin + case Get_Decl_Kind (Decl) is + when OD_Block => + return Get_Block_Last (Decl) + 1; + when OD_Body => + return Get_Block_Last (Decl + 1) + 1; + when others => + return Decl + 1; + end case; + end Get_Decl_Chain; + + function Get_Body_Stmt (Bod : O_Dnode) return O_Enode is + begin + return Dnodes.Table (Bod).Body_Stmt; + end Get_Body_Stmt; + + function Get_Body_Decl (Bod : O_Dnode) return O_Dnode is + begin + return Dnodes.Table (Bod).Body_Decl; + end Get_Body_Decl; + + function Get_Body_Parent (Bod : O_Dnode) return O_Dnode is + begin + return Dnodes.Table (Bod).Body_Parent; + end Get_Body_Parent; + + function Get_Body_Info (Bod : O_Dnode) return Int32 is + begin + return Dnodes.Table (Bod).Body_Info; + end Get_Body_Info; + + procedure Set_Body_Info (Bod : O_Dnode; Info : Int32) is + begin + Dnodes.Table (Bod).Body_Info := Info; + end Set_Body_Info; + + function Get_Decl_Ident (Decl : O_Dnode) return O_Ident is + begin + return Dnodes.Table (Decl).Id; + end Get_Decl_Ident; + + function Get_Decl_Last return O_Dnode is + begin + return Dnodes.Last; + end Get_Decl_Last; + + function Get_Block_Last (Blk : O_Dnode) return O_Dnode is + begin + return Dnodes.Table (Blk).Last; + end Get_Block_Last; + + function Get_Block_Max_Stack (Blk : O_Dnode) return Uns32 is + begin + return Dnodes.Table (Blk).Block_Max_Stack; + end Get_Block_Max_Stack; + + procedure Set_Block_Max_Stack (Blk : O_Dnode; Max : Uns32) is + begin + Dnodes.Table (Blk).Block_Max_Stack := Max; + end Set_Block_Max_Stack; + + function Get_Block_Info1 (Blk : O_Dnode) return Int32 is + begin + return Dnodes.Table (Blk).Block_Info1; + end Get_Block_Info1; + + procedure Set_Block_Info1 (Blk : O_Dnode; Info : Int32) is + begin + Dnodes.Table (Blk).Block_Info1 := Info; + end Set_Block_Info1; + + function Get_Block_Info2 (Blk : O_Dnode) return Int32 is + begin + return Dnodes.Table (Blk).Block_Info2; + end Get_Block_Info2; + + procedure Set_Block_Info2 (Blk : O_Dnode; Info : Int32) is + begin + Dnodes.Table (Blk).Block_Info2 := Info; + end Set_Block_Info2; + + function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode + is + Res : O_Dnode := Decl + 1; + begin + if Get_Decl_Kind (Res) = OD_Interface then + return Res; + else + return O_Dnode_Null; + end if; + end Get_Subprg_Interfaces; + + function Get_Interface_Chain (Decl : O_Dnode) return O_Dnode + is + Res : O_Dnode := Decl + 1; + begin + if Get_Decl_Kind (Res) = OD_Interface then + return Res; + else + return O_Dnode_Null; + end if; + end Get_Interface_Chain; + + function Get_Val_Decl (Decl : O_Dnode) return O_Dnode is + begin + return Dnodes.Table (Decl).Val_Decl; + end Get_Val_Decl; + + function Get_Val_Val (Decl : O_Dnode) return O_Cnode is + begin + return Dnodes.Table (Decl).Val_Val; + end Get_Val_Val; + + Cur_Depth : O_Depth := O_Toplevel; + + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is + begin + Dnodes.Append (Dnode_Common'(Kind => OD_Type, + Storage => O_Storage_Private, + Depth => Cur_Depth, + Reg => R_Nil, + Id => Ident, + Dtype => Atype, + Ref => 0, + Info2 => 0, + others => False)); + if Flags.Flag_Type_Name then + declare + L : O_Tnode; + begin + L := TDnodes.Last; + if Atype > L then + TDnodes.Set_Last (Atype); + TDnodes.Table (L + 1 .. Atype) := (others => O_Dnode_Null); + end if; + end; + TDnodes.Table (Atype) := Dnodes.Last; + end if; + end New_Type_Decl; + + function Get_Type_Decl (Atype : O_Tnode) return O_Dnode is + begin + if Atype <= TDnodes.Last then + return TDnodes.Table (Atype); + else + return O_Dnode_Null; + end if; + end Get_Type_Decl; + + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) + is + begin + Dnodes.Append (Dnode_Common'(Kind => OD_Const, + Storage => Storage, + Depth => Cur_Depth, + Reg => R_Nil, + Id => Ident, + Dtype => Atype, + Ref => 0, + Info2 => 0, + others => False)); + Res := Dnodes.Last; + if not Flag_Debug_Hli then + Expand_Const_Decl (Res); + end if; + end New_Const_Decl; + + procedure New_Const_Value (Cst : O_Dnode; Val : O_Cnode) is + begin + if Dnodes.Table (Cst).Info2 /= 0 then + raise Syntax_Error; + end if; + Dnodes.Table (Cst).Info2 := Int32 (Val); + if Flag_Debug_Hli then + Dnodes.Append (Dnode_Common'(Kind => OD_Const_Val, + Storage => O_Storage_Private, + Depth => Cur_Depth, + Reg => R_Nil, + Val_Decl => Cst, + Val_Val => Val, + others => False)); + else + Expand_Const_Value (Cst, Val); + end if; + end New_Const_Value; + + procedure New_Var_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) + is + begin + if Storage = O_Storage_Local then + Dnodes.Append (Dnode_Common'(Kind => OD_Local, + Storage => Storage, + Depth => Cur_Depth, + Reg => R_Nil, + Id => Ident, + Dtype => Atype, + Ref => 0, + Info2 => 0, + others => False)); + Res := Dnodes.Last; + else + Dnodes.Append (Dnode_Common'(Kind => OD_Var, + Storage => Storage, + Depth => Cur_Depth, + Reg => R_Nil, + Id => Ident, + Dtype => Atype, + Ref => 0, + Info2 => 0, + others => False)); + Res := Dnodes.Last; + if not Flag_Debug_Hli then + Expand_Var_Decl (Res); + end if; + end if; + end New_Var_Decl; + + Static_Chain_Id : O_Ident := O_Ident_Nul; + + procedure Add_Static_Chain (Interfaces : in out O_Inter_List) + is + Res : O_Dnode; + begin + if Static_Chain_Id = O_Ident_Nul then + Static_Chain_Id := Ortho_Ident.Get_Identifier ("STATIC_CHAIN"); + end if; + + Dnodes.Append (Dnode_Common'(Kind => OD_Interface, + Storage => O_Storage_Local, + Depth => Cur_Depth + 1, + Reg => R_Nil, + Id => Static_Chain_Id, + Dtype => O_Tnode_Ptr, + Ref => 0, + Info2 => 0, + others => False)); + Res := Dnodes.Last; + New_Interface (Res, Interfaces.Abi); + end Add_Static_Chain; + + procedure Start_Subprogram_Decl (Interfaces : out O_Inter_List) + is + Storage : O_Storage; + begin + Storage := Get_Decl_Storage (Dnodes.Last); + if Cur_Depth /= O_Toplevel then + case Storage is + when O_Storage_External + | O_Storage_Local => + null; + when O_Storage_Public => + raise Syntax_Error; + when O_Storage_Private => + Storage := O_Storage_Local; + Set_Decl_Storage (Dnodes.Last, Storage); + end case; + end if; + Start_Subprogram (Dnodes.Last, Interfaces.Abi); + Interfaces.Decl := Dnodes.Last; + if Storage = O_Storage_Local then + Add_Static_Chain (Interfaces); + end if; + end Start_Subprogram_Decl; + + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode) + is + begin + Dnodes.Append (Dnode_Common'(Kind => OD_Function, + Storage => Storage, + Depth => Cur_Depth, + Reg => R_Nil, + Id => Ident, + Dtype => Rtype, + Ref => 0, + Info2 => 0, + others => False)); + Start_Subprogram_Decl (Interfaces); + end Start_Function_Decl; + + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage) + is + begin + Dnodes.Append (Dnode_Common'(Kind => OD_Procedure, + Storage => Storage, + Depth => Cur_Depth, + Reg => R_Nil, + Id => Ident, + Dtype => O_Tnode_Null, + Ref => 0, + Info2 => 0, + others => False)); + Start_Subprogram_Decl (Interfaces); + end Start_Procedure_Decl; + + procedure New_Interface_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode) + is + begin + Dnodes.Append (Dnode_Common'(Kind => OD_Interface, + Storage => O_Storage_Local, + Depth => Cur_Depth + 1, + Reg => R_Nil, + Id => Ident, + Dtype => Atype, + Ref => 0, + Info2 => 0, + others => False)); + Res := Dnodes.Last; + New_Interface (Res, Interfaces.Abi); + end New_Interface_Decl; + + procedure Set_Local_Offset (Decl : O_Dnode; Off : Int32) is + begin + Dnodes.Table (Decl).Ref := Off; + end Set_Local_Offset; + + function Get_Local_Offset (Decl : O_Dnode) return Int32 is + begin + return Dnodes.Table (Decl).Ref; + end Get_Local_Offset; + + function Get_Inter_Offset (Inter : O_Dnode) return Int32 is + begin + return Dnodes.Table (Inter).Ref; + end Get_Inter_Offset; + + procedure Set_Decl_Info (Decl : O_Dnode; Ref : Int32) is + begin + Dnodes.Table (Decl).Ref := Ref; + end Set_Decl_Info; + + function Get_Decl_Info (Decl : O_Dnode) return Int32 is + begin + return Dnodes.Table (Decl).Ref; + end Get_Decl_Info; + + procedure Set_Subprg_Stack (Decl : O_Dnode; Val : Int32) is + begin + Dnodes.Table (Decl).Info2 := Val; + end Set_Subprg_Stack; + + function Get_Subprg_Stack (Decl : O_Dnode) return Int32 is + begin + return Dnodes.Table (Decl).Info2; + end Get_Subprg_Stack; + + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; Res : out O_Dnode) is + begin + Res := Interfaces.Decl; + Finish_Subprogram (Res, Interfaces.Abi); + end Finish_Subprogram_Decl; + + Cur_Block : O_Dnode := O_Dnode_Null; + + function Start_Declare_Stmt return O_Dnode is + begin + Dnodes.Append (Dnode_Common'(Kind => OD_Block, + Storage => O_Storage_Local, + Depth => Cur_Depth, + Reg => R_Nil, + Last => O_Dnode_Null, + Block_Max_Stack => 0, + Block_Info1 => 0, + Block_Info2 => 0, + others => False)); + Cur_Block := Dnodes.Last; + return Cur_Block; + end Start_Declare_Stmt; + + procedure Finish_Declare_Stmt (Parent : O_Dnode) is + begin + Dnodes.Table (Cur_Block).Last := Dnodes.Last; + Cur_Block := Parent; + end Finish_Declare_Stmt; + + function Start_Subprogram_Body (Decl : O_Dnode; Stmt : O_Enode) + return O_Dnode + is + Res : O_Dnode; + begin + Dnodes.Append (Dnode_Common'(Kind => OD_Body, + Storage => O_Storage_Local, + Depth => Cur_Depth, + Reg => R_Nil, + Body_Parent => Context, + Body_Decl => Decl, + Body_Stmt => Stmt, + Body_Info => 0, + others => False)); + Res := Dnodes.Last; + Context := Res; + Cur_Depth := Cur_Depth + 1; + return Res; + end Start_Subprogram_Body; + + procedure Finish_Subprogram_Body is + begin + Cur_Depth := Cur_Depth - 1; + Context := Get_Body_Parent (Context); + end Finish_Subprogram_Body; + + +-- function Image (Decl : O_Dnode) return String is +-- begin +-- return O_Dnode'Image (Decl); +-- end Image; + + procedure Disp_Decl_Name (Decl : O_Dnode) + is + use Ada.Text_IO; + use Ortho_Ident; + Id : O_Ident; + begin + Id := Get_Decl_Ident (Decl); + if Is_Equal (Id, O_Ident_Nul) then + declare + Res : String := O_Dnode'Image (Decl); + begin + Res (1) := '?'; + Put (Res); + end; + else + Put (Get_String (Id)); + end if; + end Disp_Decl_Name; + + procedure Disp_Decl_Storage (Decl : O_Dnode) + is + use Ada.Text_IO; + begin + case Get_Decl_Storage (Decl) is + when O_Storage_Local => + Put ("local"); + when O_Storage_External => + Put ("external"); + when O_Storage_Public => + Put ("public"); + when O_Storage_Private => + Put ("private"); + end case; + end Disp_Decl_Storage; + + procedure Disp_Decl (Indent : Natural; Decl : O_Dnode) + is + use Ada.Text_IO; + use Ortho_Ident; + use Ortho_Code.Debug.Int32_IO; + begin + Set_Col (Count (Indent)); + Put (Int32 (Decl), 0); + Set_Col (Count (7 + Indent)); + case Get_Decl_Kind (Decl) is + when OD_Type => + Put ("type "); + Disp_Decl_Name (Decl); + Put (" is "); + Put (Int32 (Get_Decl_Type (Decl)), 0); + when OD_Function => + Disp_Decl_Storage (Decl); + Put (" function "); + Disp_Decl_Name (Decl); + Put (" return "); + Put (Int32 (Get_Decl_Type (Decl)), 0); + when OD_Procedure => + Disp_Decl_Storage (Decl); + Put (" procedure "); + Disp_Decl_Name (Decl); + when OD_Interface => + Put (" interface "); + Disp_Decl_Name (Decl); + Put (": "); + Put (Int32 (Get_Decl_Type (Decl)), 0); + Put (", offset="); + Put (Get_Inter_Offset (Decl), 0); + when OD_Const => + Disp_Decl_Storage (Decl); + Put (" const "); + Disp_Decl_Name (Decl); + Put (": "); + Put (Int32 (Get_Decl_Type (Decl)), 0); + when OD_Const_Val => + Put ("constant "); + Disp_Decl_Name (Get_Val_Decl (Decl)); + Put (": "); + Put (Int32 (Get_Val_Val (Decl)), 0); + when OD_Local => + Put ("local "); + Disp_Decl_Name (Decl); + Put (": "); + Put (Int32 (Get_Decl_Type (Decl)), 0); + Put (", offset="); + Put (Get_Inter_Offset (Decl), 0); + when OD_Var => + Disp_Decl_Storage (Decl); + Put (" var "); + Disp_Decl_Name (Decl); + Put (": "); + Put (Int32 (Get_Decl_Type (Decl)), 0); + when OD_Body => + Put ("body of "); + Put (Int32 (Get_Body_Decl (Decl)), 0); + Put (", stmt at "); + Put (Int32 (Get_Body_Stmt (Decl)), 0); + when OD_Block => + Put ("block until "); + Put (Int32 (Get_Block_Last (Decl)), 0); +-- when others => +-- Put (OD_Kind'Image (Get_Decl_Kind (Decl))); + end case; + New_Line; + end Disp_Decl; + + procedure Disp_Decls (Indent : Natural; First, Last : O_Dnode) + is + N : O_Dnode; + begin + N := First; + while N <= Last loop + case Get_Decl_Kind (N) is + when OD_Body => + Disp_Decl (Indent, N); + Ortho_Code.Exprs.Disp_Subprg_Body + (Indent + 2, Get_Body_Stmt (N)); + N := N + 1; + when OD_Block => + -- Skip inner bindings. + N := Get_Block_Last (N) + 1; + when others => + Disp_Decl (Indent, N); + N := N + 1; + end case; + end loop; + end Disp_Decls; + + procedure Disp_Block (Indent : Natural; Start : O_Dnode) + is + Last : O_Dnode; + begin + if Get_Decl_Kind (Start) /= OD_Block then + Disp_Decl (Indent, Start); + raise Program_Error; + end if; + Last := Get_Block_Last (Start); + Disp_Decl (Indent, Start); + Disp_Decls (Indent, Start + 1, Last); + end Disp_Block; + + procedure Disp_All_Decls + is + begin + if False then + for I in Dnodes.First .. Dnodes.Last loop + Disp_Decl (1, I); + end loop; + end if; + + Disp_Decls (1, Dnodes.First, Dnodes.Last); + end Disp_All_Decls; + + procedure Disp_Stats + is + use Ada.Text_IO; + begin + Put_Line ("Number of Dnodes: " & O_Dnode'Image (Dnodes.Last)); + Put_Line ("Number of TDnodes: " & O_Tnode'Image (TDnodes.Last)); + end Disp_Stats; + + procedure Mark (M : out Mark_Type) is + begin + M.Dnode := Dnodes.Last; + M.TDnode := TDnodes.Last; + end Mark; + + procedure Release (M : Mark_Type) is + begin + Dnodes.Set_Last (M.Dnode); + TDnodes.Set_Last (M.TDnode); + end Release; + + procedure Finish is + begin + Dnodes.Free; + TDnodes.Free; + end Finish; +end Ortho_Code.Decls; diff --git a/ortho/mcode/ortho_code-decls.ads b/ortho/mcode/ortho_code-decls.ads new file mode 100644 index 0000000..1c8b451 --- /dev/null +++ b/ortho/mcode/ortho_code-decls.ads @@ -0,0 +1,201 @@ +-- Mcode back-end for ortho - Declarations handling. +-- 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 Ortho_Code.Abi; + +package Ortho_Code.Decls is + -- Kind of a declaration. + type OD_Kind is (OD_Type, + OD_Const, OD_Const_Val, + OD_Var, OD_Local, + OD_Function, OD_Procedure, + OD_Interface, + OD_Body, + OD_Block); + + -- Return the kind of declaration DECL. + function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind; + + -- Return the type of a declaration. + function Get_Decl_Type (Decl : O_Dnode) return O_Tnode; + + -- Return the identifier of a declaration. + function Get_Decl_Ident (Decl : O_Dnode) return O_Ident; + + -- Return the storage of a declaration. + function Get_Decl_Storage (Decl : O_Dnode) return O_Storage; + + -- Return the depth of a declaration. + function Get_Decl_Depth (Decl : O_Dnode) return O_Depth; + + -- Register for the declaration. + function Get_Decl_Reg (Decl : O_Dnode) return O_Reg; + procedure Set_Decl_Reg (Decl : O_Dnode; Reg : O_Reg); + + -- Return the next decl (in the same scope) after DECL. + -- This skips declarations in an inner block. + function Get_Decl_Chain (Decl : O_Dnode) return O_Dnode; + + -- Get the last declaration. + function Get_Decl_Last return O_Dnode; + + -- Return the subprogram declaration correspondig to body BOD. + function Get_Body_Decl (Bod : O_Dnode) return O_Dnode; + + -- Return the parent of a body. + function Get_Body_Parent (Bod : O_Dnode) return O_Dnode; + + -- Get the entry statement of body DECL. + function Get_Body_Stmt (Bod : O_Dnode) return O_Enode; + + -- Get/Set the info field of a body. + function Get_Body_Info (Bod : O_Dnode) return Int32; + procedure Set_Body_Info (Bod : O_Dnode; Info : Int32); + + -- Get the last declaration of block BLK. + function Get_Block_Last (Blk : O_Dnode) return O_Dnode; + + -- Get/Set the block max stack offset. + function Get_Block_Max_Stack (Blk : O_Dnode) return Uns32; + procedure Set_Block_Max_Stack (Blk : O_Dnode; Max : Uns32); + + -- Info on blocks. + function Get_Block_Info1 (Blk : O_Dnode) return Int32; + procedure Set_Block_Info1 (Blk : O_Dnode; Info : Int32); + function Get_Block_Info2 (Blk : O_Dnode) return Int32; + procedure Set_Block_Info2 (Blk : O_Dnode; Info : Int32); + + -- Get the declaration and the value associated with a constant value. + function Get_Val_Decl (Decl : O_Dnode) return O_Dnode; + function Get_Val_Val (Decl : O_Dnode) return O_Cnode; + + -- Declare a type. + -- This simply gives a name to a type. + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode); + + -- If Flag_Type_Name is set, a map from type to name is maintained. + function Get_Type_Decl (Atype : O_Tnode) return O_Dnode; + + -- Set/Get the offset (or register) of interface or local DECL. + -- To be used by ABI. + procedure Set_Local_Offset (Decl : O_Dnode; Off : Int32); + function Get_Local_Offset (Decl : O_Dnode) return Int32; + + -- Get/Set user info on subprogram, variable, constant declaration. + procedure Set_Decl_Info (Decl : O_Dnode; Ref : Int32); + function Get_Decl_Info (Decl : O_Dnode) return Int32; + + -- Get/Set the stack size of subprogram arguments. + procedure Set_Subprg_Stack (Decl : O_Dnode; Val : Int32); + function Get_Subprg_Stack (Decl : O_Dnode) return Int32; + + -- Get the first interface of a subprogram declaration. + function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode; + + -- Get the next interface. + -- End of interface chain when result is O_Dnode_Null. + function Get_Interface_Chain (Decl : O_Dnode) return O_Dnode; + + -- Declare a constant. + -- This simply gives a name to a constant value or aggregate. + -- A constant cannot be modified and its storage cannot be local. + -- ATYPE must be constrained. + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); + + -- Set the value to CST. + procedure New_Const_Value (Cst : O_Dnode; Val : O_Cnode); + + -- Create a variable declaration. + -- A variable can be local only inside a function. + -- ATYPE must be constrained. + procedure New_Var_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode); + + type O_Inter_List is limited private; + + -- Start a subprogram declaration. + -- Note: nested subprograms are allowed, ie o_storage_local subprograms can + -- be declared inside a subprograms. It is not allowed to declare + -- o_storage_external subprograms inside a subprograms. + -- Return type and interfaces cannot be a composite type. + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode); + -- For a subprogram without return value. + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage); + + -- Add an interface declaration to INTERFACES. + procedure New_Interface_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode); + -- Finish the function declaration, get the node and a statement list. + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; Res : out O_Dnode); + + -- Start subprogram body of DECL. STMT is the corresponding statement. + -- Return the declaration for the body. + function Start_Subprogram_Body (Decl : O_Dnode; Stmt : O_Enode) + return O_Dnode; + procedure Finish_Subprogram_Body; + + -- Start a declarative region. + function Start_Declare_Stmt return O_Dnode; + procedure Finish_Declare_Stmt (Parent : O_Dnode); + + procedure Disp_All_Decls; + procedure Disp_Block (Indent : Natural; Start : O_Dnode); + procedure Disp_Decl_Name (Decl : O_Dnode); + procedure Disp_Decl (Indent : Natural; Decl : O_Dnode); + procedure Disp_Stats; + + type Mark_Type is limited private; + procedure Mark (M : out Mark_Type); + procedure Release (M : Mark_Type); + + procedure Finish; +private + type O_Inter_List is record + -- The declaration of the subprogram. + Decl : O_Dnode; + + -- Last declared parameter. + Last_Param : O_Dnode; + + -- Data for ABI. + Abi : Ortho_Code.Abi.O_Abi_Subprg; + end record; + + type Mark_Type is record + Dnode : O_Dnode; + TDnode : O_Tnode; + end record; + +end Ortho_Code.Decls; diff --git a/ortho/mcode/ortho_code-disps.adb b/ortho/mcode/ortho_code-disps.adb new file mode 100644 index 0000000..9afc6b7 --- /dev/null +++ b/ortho/mcode/ortho_code-disps.adb @@ -0,0 +1,789 @@ +-- Mcode back-end for ortho - Internal tree dumper. +-- 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 Ada.Text_IO; use Ada.Text_IO; +with Ortho_Code.Debug; +with Ortho_Code.Consts; +with Ortho_Code.Decls; +with Ortho_Code.Types; +with Ortho_Code.Flags; +with Ortho_Ident; +with Interfaces; + +package body Ortho_Code.Disps is + procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode); + procedure Disp_Expr (Expr : O_Enode); + procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False); + + procedure Disp_Indent (Indent : Natural) + is + begin + Put ((1 .. 2 * Indent => ' ')); + end Disp_Indent; + + procedure Disp_Ident (Id : O_Ident) + is + use Ortho_Ident; + begin + Put (Get_String (Id)); + end Disp_Ident; + + procedure Disp_Storage (Storage : O_Storage) is + begin + case Storage is + when O_Storage_External => + Put ("external"); + when O_Storage_Public => + Put ("public"); + when O_Storage_Private => + Put ("private"); + when O_Storage_Local => + Put ("local"); + end case; + end Disp_Storage; + + procedure Disp_Label (Label : O_Enode) + is + N : Int32; + begin + case Get_Expr_Kind (Label) is + when OE_Label => + Put ("label"); + N := Int32 (Label); + when OE_Loop => + Put ("loop"); + N := Int32 (Label); + when OE_BB => + Put ("BB"); + N := Get_BB_Number (Label); + when others => + raise Program_Error; + end case; + Put (Int32'Image (N)); + Put (":"); + end Disp_Label; + + procedure Disp_Call (Call : O_Enode) + is + Arg : O_Enode; + begin + Decls.Disp_Decl_Name (Get_Call_Subprg (Call)); + + Arg := Get_Arg_Link (Call); + if Arg /= O_Enode_Null then + Put (" ("); + loop + Disp_Expr (Get_Expr_Operand (Arg)); + Arg := Get_Arg_Link (Arg); + exit when Arg = O_Enode_Null; + Put (", "); + end loop; + Put (")"); + end if; + end Disp_Call; + + procedure Put_Trim (Str : String) is + begin + if Str (Str'First) = ' ' then + Put (Str (Str'First + 1 .. Str'Last)); + else + Put (Str); + end if; + end Put_Trim; + + procedure Disp_Typed_Lit (Lit : O_Cnode; Val : String) + is + use Ortho_Code.Consts; + begin + Disp_Type (Get_Const_Type (Lit)); + Put ("'["); + Put_Trim (Val); + Put (']'); + end Disp_Typed_Lit; + + procedure Disp_Lit (Lit : O_Cnode) + is + use Interfaces; + use Ortho_Code.Consts; + begin + case Get_Const_Kind (Lit) is + when OC_Unsigned => + Disp_Typed_Lit (Lit, Unsigned_64'Image (Get_Const_U64 (Lit))); + when OC_Signed => + Disp_Typed_Lit (Lit, Integer_64'Image (Get_Const_I64 (Lit))); + when OC_Subprg_Address => + Disp_Type (Get_Const_Type (Lit)); + Put ("'subprg_addr ("); + Decls.Disp_Decl_Name (Get_Const_Decl (Lit)); + Put (")"); + when OC_Address => + Disp_Type (Get_Const_Type (Lit)); + Put ("'address ("); + Decls.Disp_Decl_Name (Get_Const_Decl (Lit)); + Put (")"); + when OC_Sizeof => + Disp_Type (Get_Const_Type (Lit)); + Put ("'sizeof ("); + Disp_Type (Get_Sizeof_Type (Lit)); + Put (")"); + when OC_Null => + Disp_Type (Get_Const_Type (Lit)); + Put ("'[null]"); + when OC_Lit => + declare + L : O_Cnode; + begin + L := Types.Get_Type_Enum_Lit + (Get_Const_Type (Lit), Get_Lit_Value (Lit)); + Disp_Typed_Lit + (Lit, Ortho_Ident.Get_String (Get_Lit_Ident (L))); + end; + when OC_Array => + Put ('{'); + for I in 1 .. Get_Const_Aggr_Length (Lit) loop + if I /= 1 then + Put (", "); + end if; + Disp_Lit (Get_Const_Aggr_Element (Lit, I - 1)); + end loop; + Put ('}'); + when OC_Record => + declare + use Ortho_Code.Types; + F : O_Fnode; + begin + F := Get_Type_Record_Fields (Get_Const_Type (Lit)); + Put ('{'); + for I in 1 .. Get_Const_Aggr_Length (Lit) loop + if I /= 1 then + Put (", "); + end if; + Put ('.'); + Disp_Ident (Get_Field_Ident (F)); + Put (" = "); + Disp_Lit (Get_Const_Aggr_Element (Lit, I - 1)); + F := Get_Field_Chain (F); + end loop; + Put ('}'); + end; + when others => + Put ("*lit " & OC_Kind'Image (Get_Const_Kind (Lit)) & '*'); + end case; + end Disp_Lit; + + procedure Disp_Expr (Expr : O_Enode) + is + Kind : OE_Kind; + begin + Kind := Get_Expr_Kind (Expr); + case Kind is + when OE_Const => + case Get_Expr_Mode (Expr) is + when Mode_I8 + | Mode_I16 + | Mode_I32 => + Put_Trim (Int32'Image (To_Int32 (Get_Expr_Low (Expr)))); + when Mode_U8 + | Mode_U16 + | Mode_U32 => + Put_Trim (Uns32'Image (Get_Expr_Low (Expr))); + when others => + Put ("const:"); + Debug.Disp_Mode (Get_Expr_Mode (Expr)); + end case; + when OE_Lit => + Disp_Lit (Get_Expr_Lit (Expr)); + when OE_Case_Expr => + Put ("{case}"); + when OE_Kind_Dyadic + | OE_Kind_Cmp + | OE_Add + | OE_Mul + | OE_Shl => + Put ("("); + Disp_Expr (Get_Expr_Left (Expr)); + Put (' '); + case Kind is + when OE_Eq => + Put ('='); + when OE_Neq => + Put ("/="); + when OE_Lt => + Put ("<"); + when OE_Gt => + Put (">"); + when OE_Ge => + Put (">="); + when OE_Le => + Put ("<="); + when OE_Add => + Put ('+'); + when OE_Mul => + Put ('*'); + when OE_Add_Ov => + Put ("+#"); + when OE_Sub_Ov => + Put ("-#"); + when OE_Mul_Ov => + Put ("*#"); + when OE_Shl => + Put ("<<"); + when OE_And => + Put ("and"); + when OE_Or => + Put ("or"); + when others => + Put (OE_Kind'Image (Kind)); + end case; + Put (' '); + Disp_Expr (Get_Expr_Right (Expr)); + Put (")"); + when OE_Not => + Put ("not "); + Disp_Expr (Get_Expr_Operand (Expr)); + when OE_Neg_Ov => + Put ("neg "); + Disp_Expr (Get_Expr_Operand (Expr)); + when OE_Abs_Ov => + Put ("abs "); + Disp_Expr (Get_Expr_Operand (Expr)); + when OE_Indir => + declare + Op : O_Enode; + begin + Op := Get_Expr_Operand (Expr); + case Get_Expr_Kind (Op) is + when OE_Addrg + | OE_Addrl => + Decls.Disp_Decl_Name (Get_Addr_Object (Op)); + when others => + --Put ("*"); + Disp_Expr (Op); + end case; + end; + when OE_Addrl + | OE_Addrg => + -- Put ('@'); + Decls.Disp_Decl_Name (Get_Addr_Object (Expr)); + when OE_Call => + Disp_Call (Expr); + when OE_Alloca => + Put ("alloca ("); + Disp_Expr (Get_Expr_Operand (Expr)); + Put (")"); + when OE_Conv => + Disp_Type (Get_Conv_Type (Expr)); + Put ("'conv ("); + Disp_Expr (Get_Expr_Operand (Expr)); + Put (")"); + when OE_Conv_Ptr => + Disp_Type (Get_Conv_Type (Expr)); + Put ("'address ("); + Disp_Expr (Get_Expr_Operand (Expr)); + Put (")"); + when OE_Typed => + Disp_Type (Get_Conv_Type (Expr)); + Put ("'"); + -- Note: there is always parenthesis around comparison. + Disp_Expr (Get_Expr_Operand (Expr)); + when OE_Record_Ref => + Disp_Expr (Get_Expr_Operand (Expr)); + Put ("."); + Disp_Ident (Types.Get_Field_Ident (Get_Ref_Field (Expr))); + when OE_Access_Ref => + Disp_Expr (Get_Expr_Operand (Expr)); + Put (".all"); + when OE_Index_Ref => + Disp_Expr (Get_Expr_Operand (Expr)); + Put ('['); + Disp_Expr (Get_Ref_Index (Expr)); + Put (']'); + when OE_Slice_Ref => + Disp_Expr (Get_Expr_Operand (Expr)); + Put ('['); + Disp_Expr (Get_Ref_Index (Expr)); + Put ("...]"); + when OE_Get_Stack => + Put ("%sp"); + when OE_Get_Frame => + Put ("%fp"); + when others => + Put_Line (Standard_Error, "disps.disp_expr: unknown expr " + & OE_Kind'Image (Kind)); + end case; + end Disp_Expr; + + procedure Disp_Fields (Indent : Natural; Atype : O_Tnode) + is + use Types; + Nbr : Uns32; + F : O_Fnode; + begin + Nbr := Get_Type_Record_Nbr_Fields (Atype); + F := Get_Type_Record_Fields (Atype); + for I in 1 .. Nbr loop + Disp_Indent (Indent); + Disp_Ident (Get_Field_Ident (F)); + Put (": "); + Disp_Type (Get_Field_Type (F)); + Put (";"); + New_Line; + F := Get_Field_Chain (F); + end loop; + end Disp_Fields; + + procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False) + is + use Types; + Kind : OT_Kind; + Decl : O_Dnode; + begin + if not Force then + Decl := Decls.Get_Type_Decl (Atype); + if Decl /= O_Dnode_Null then + Decls.Disp_Decl_Name (Decl); + return; + end if; + end if; + + Kind := Get_Type_Kind (Atype); + case Kind is + when OT_Signed => + Put ("signed ("); + Put_Trim (Uns32'Image (8 * Get_Type_Size (Atype))); + Put (")"); + when OT_Unsigned => + Put ("unsigned ("); + Put_Trim (Uns32'Image (8 * Get_Type_Size (Atype))); + Put (")"); + when OT_Float => + Put ("float"); + when OT_Access => + Put ("access"); + declare + Acc_Type : O_Tnode; + begin + Acc_Type := Get_Type_Access_Type (Atype); + if Acc_Type /= O_Tnode_Null then + Put (' '); + Disp_Type (Acc_Type); + end if; + end; + when OT_Ucarray => + Put ("array ["); + Disp_Type (Get_Type_Ucarray_Index (Atype)); + Put ("] of "); + Disp_Type (Get_Type_Ucarray_Element (Atype)); + when OT_Subarray => + Put ("subarray "); + Disp_Type (Get_Type_Subarray_Base (Atype)); + Put ("["); + Put_Trim (Uns32'Image (Get_Type_Subarray_Length (Atype))); + Put ("]"); + when OT_Record => + Put_Line ("record"); + Disp_Fields (1, Atype); + Put ("end record"); + when OT_Union => + Put_Line ("union"); + Disp_Fields (1, Atype); + Put ("end union"); + when OT_Boolean => + declare + Lit : O_Cnode; + begin + Put ("boolean {"); + Lit := Get_Type_Bool_False (Atype); + Disp_Ident (Consts.Get_Lit_Ident (Lit)); + Put (", "); + Lit := Get_Type_Bool_True (Atype); + Disp_Ident (Consts.Get_Lit_Ident (Lit)); + Put ("}"); + end; + when OT_Enum => + declare + use Consts; + Lit : O_Cnode; + begin + Put ("enum {"); + Lit := Get_Type_Enum_Lits (Atype); + for I in 1 .. Get_Type_Enum_Nbr_Lits (Atype) loop + if I /= 1 then + Put (", "); + end if; + Disp_Ident (Get_Lit_Ident (Lit)); + Put (" ="); + Put (Uns32'Image (I - 1)); + Lit := Get_Lit_Chain (Lit); + end loop; + Put ('}'); + end; + when others => + Put_Line (Standard_Error, "disps.disp_type: unknown type " + & OT_Kind'Image (Kind)); + end case; + end Disp_Type; + + procedure Disp_Decl_Storage (Decl : O_Dnode) is + begin + Disp_Storage (Decls.Get_Decl_Storage (Decl)); + Put (' '); + end Disp_Decl_Storage; + + procedure Disp_Subprg_Decl (Indent : Natural; Decl : O_Dnode) + is + use Decls; + Kind : OD_Kind; + Inter : O_Dnode; + begin + Disp_Decl_Storage (Decl); + Kind := Get_Decl_Kind (Decl); + case Kind is + when OD_Function => + Put ("function "); + when OD_Procedure => + Put ("procedure "); + when others => + raise Program_Error; + end case; + + Disp_Decl_Name (Decl); + Inter := Get_Subprg_Interfaces (Decl); + Put (" ("); + New_Line; + if Inter /= O_Dnode_Null then + loop + Disp_Indent (Indent + 1); + Disp_Decl_Name (Inter); + Put (": "); + Disp_Type (Get_Decl_Type (Inter)); + Inter := Get_Interface_Chain (Inter); + exit when Inter = O_Dnode_Null; + Put (";"); + New_Line; + end loop; + else + Disp_Indent (Indent + 1); + end if; + Put (")"); + if Kind = OD_Function then + New_Line; + Disp_Indent (Indent + 1); + Put ("return "); + Disp_Type (Get_Decl_Type (Decl)); + end if; + end Disp_Subprg_Decl; + + procedure Disp_Decl (Indent : Natural; + Decl : O_Dnode; + Nl : Boolean := False) + is + use Decls; + Kind : OD_Kind; + Dtype : O_Tnode; + begin + Kind := Get_Decl_Kind (Decl); + if Kind = OD_Interface then + return; + end if; + Disp_Indent (Indent); + case Kind is + when OD_Type => + Dtype := Get_Decl_Type (Decl); + Put ("type "); + Disp_Decl_Name (Decl); + Put (" is "); + Disp_Type (Dtype, True); + Put_Line (";"); + when OD_Local + | OD_Var => + Disp_Decl_Storage (Decl); + Put ("var "); + Disp_Decl_Name (Decl); + Put (" : "); + Disp_Type (Get_Decl_Type (Decl)); + Put_Line (";"); + when OD_Const => + Disp_Decl_Storage (Decl); + Put ("constant "); + Disp_Decl_Name (Decl); + Put (" : "); + Disp_Type (Get_Decl_Type (Decl)); + Put_Line (";"); + when OD_Const_Val => + Put ("constant "); + Disp_Decl_Name (Get_Val_Decl (Decl)); + Put (" := "); + Disp_Lit (Get_Val_Val (Decl)); + Put_Line (";"); + when OD_Function + | OD_Procedure => + Disp_Subprg_Decl (Indent, Decl); + Put_Line (";"); + when OD_Interface => + null; + when OD_Body => + -- Put ("body "); + Disp_Subprg_Decl (Indent, Get_Body_Decl (Decl)); + -- Disp_Decl_Name (Get_Body_Decl (Decl)); + New_Line; + Disp_Subprg (Indent, Get_Body_Stmt (Decl)); + when others => + Put_Line (Standard_Error, "debug.disp_decl: unknown decl " + & OD_Kind'Image (Kind)); + end case; + if Nl then + New_Line; + end if; + end Disp_Decl; + + procedure Disp_Stmt (Indent : in out Natural; Stmt : O_Enode) + is + use Decls; + Expr : O_Enode; + begin + case Get_Expr_Kind (Stmt) is + when OE_Beg => + Disp_Indent (Indent); + Put_Line ("declare"); + declare + Last : O_Dnode; + Decl : O_Dnode; + begin + Decl := Get_Block_Decls (Stmt); + Last := Get_Block_Last (Decl); + Decl := Decl + 1; + while Decl <= Last loop + case Get_Decl_Kind (Decl) is + when OD_Block => + Decl := Get_Block_Last (Decl) + 1; + when others => + Disp_Decl (Indent + 1, Decl, False); + Decl := Decl + 1; + end case; + end loop; + end; + Disp_Indent (Indent); + Put_Line ("begin"); + Indent := Indent + 1; + when OE_End => + Indent := Indent - 1; + Disp_Indent (Indent); + Put_Line ("end;"); + when OE_Line => + Disp_Indent (Indent); + Put_Line ("#line" & Int32'Image (Get_Expr_Line_Number (Stmt))); + when OE_BB => + Disp_Indent (Indent); + Put_Line ("# BB" & Int32'Image (Get_BB_Number (Stmt))); + when OE_Asgn => + Disp_Indent (Indent); + Disp_Expr (Get_Assign_Target (Stmt)); + Put (" := "); + Disp_Expr (Get_Expr_Operand (Stmt)); + Put_Line (";"); + when OE_Call => + Disp_Indent (Indent); + Disp_Call (Stmt); + Put_Line (";"); + when OE_Jump_F => + Disp_Indent (Indent); + Put ("jump "); + Disp_Label (Get_Jump_Label (Stmt)); + Put (" if not "); + Disp_Expr (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Jump_T => + Disp_Indent (Indent); + Put ("jump "); + Disp_Label (Get_Jump_Label (Stmt)); + Put (" if "); + Disp_Expr (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Jump => + Disp_Indent (Indent); + Put ("jump "); + Disp_Label (Get_Jump_Label (Stmt)); + New_Line; + when OE_Label => + Disp_Indent (Indent); + Disp_Label (Stmt); + New_Line; + when OE_Ret => + Disp_Indent (Indent); + Put ("return"); + Expr := Get_Expr_Operand (Stmt); + if Expr /= O_Enode_Null then + Put (" "); + Disp_Expr (Expr); + end if; + Put_Line (";"); + when OE_Set_Stack => + Disp_Indent (Indent); + Put ("%sp := "); + Disp_Expr (Get_Expr_Operand (Stmt)); + Put_Line (";"); + when OE_Leave => + Disp_Indent (Indent); + Put_Line ("# leave"); + when OE_If => + Disp_Indent (Indent); + Put ("if "); + Disp_Expr (Get_Expr_Operand (Stmt)); + Put (" then"); + New_Line; + Indent := Indent + 1; + when OE_Elsif => + Disp_Indent (Indent - 1); + Expr := Get_Expr_Operand (Stmt); + if Expr /= O_Enode_Null then + Put ("elsif "); + Disp_Expr (Expr); + Put (" then"); + else + Put ("else"); + end if; + New_Line; + when OE_Endif => + Indent := Indent - 1; + Disp_Indent (Indent); + Put_Line ("end if;"); + when OE_Loop => + Disp_Indent (Indent); + Disp_Label (Stmt); + New_Line; + Indent := Indent + 1; + when OE_Exit => + Disp_Indent (Indent); + Put ("exit "); + Disp_Label (Get_Jump_Label (Stmt)); + Put (";"); + New_Line; + when OE_Next => + Disp_Indent (Indent); + Put ("next "); + Disp_Label (Get_Jump_Label (Stmt)); + Put (";"); + New_Line; + when OE_Eloop => + Indent := Indent - 1; + Disp_Indent (Indent); + Put_Line ("end loop;"); + when OE_Case => + Disp_Indent (Indent); + Put ("case "); + Disp_Expr (Get_Expr_Operand (Stmt)); + Put (" is"); + New_Line; + if Debug.Flag_Debug_Hli then + Indent := Indent + 2; + end if; + when OE_Case_Branch => + Disp_Indent (Indent - 1); + Put ("when "); + declare + C : O_Enode; + L, H : O_Enode; + begin + C := Get_Case_Branch_Choice (Stmt); + loop + L := Get_Expr_Left (C); + H := Get_Expr_Right (C); + if L = O_Enode_Null then + Put ("others"); + else + Disp_Expr (L); + if H /= O_Enode_Null then + Put (" ... "); + Disp_Expr (H); + end if; + end if; + C := Get_Case_Choice_Link (C); + exit when C = O_Enode_Null; + New_Line; + Disp_Indent (Indent - 1); + Put (" | "); + end loop; + Put (" =>"); + New_Line; + end; + when OE_Case_End => + Indent := Indent - 2; + Disp_Indent (Indent); + Put ("end case;"); + New_Line; + when others => + Put_Line (Standard_Error, "debug.disp_stmt: unknown statement " & + OE_Kind'Image (Get_Expr_Kind (Stmt))); + end case; + end Disp_Stmt; + + procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode) + is + Stmt : O_Enode; + N_Ident : Natural := Ident; + Kind : OE_Kind; + begin + Stmt := S_Entry; + loop + Stmt := Get_Stmt_Link (Stmt); + Kind := Get_Expr_Kind (Stmt); + Disp_Stmt (N_Ident, Stmt); + exit when Get_Expr_Kind (Stmt) = OE_Leave; + end loop; + end Disp_Subprg; + + Last_Decl : O_Dnode := O_Dnode_First; + + procedure Disp_Decls_Until (Last : O_Dnode; Nl : Boolean := False) is + begin + while Last_Decl <= Last loop + Disp_Decl (0, Last_Decl, Nl); + Last_Decl := Last_Decl + 1; + end loop; + end Disp_Decls_Until; + + procedure Disp_Subprg (Subprg : Subprogram_Data_Acc) + is + use Decls; + begin + Disp_Decls_Until (Subprg.D_Body, True); + if Get_Decl_Kind (Last_Decl) /= OD_Block then + raise Program_Error; + end if; + if Debug.Flag_Debug_Keep then + -- If nodes are kept, the next declaration to be displayed (at top + -- level) is the one that follow the subprogram block. + Last_Decl := Get_Block_Last (Last_Decl) + 1; + else + -- If nodes are not kept, this subprogram block will be freed, and + -- the next declaration is the block itself. + Last_Decl := Subprg.D_Body; + end if; + end Disp_Subprg; + + procedure Init is + begin + Flags.Flag_Type_Name := True; + end Init; + + procedure Finish is + begin + Disp_Decls_Until (Decls.Get_Decl_Last, True); + end Finish; + +end Ortho_Code.Disps; diff --git a/ortho/mcode/ortho_code-disps.ads b/ortho/mcode/ortho_code-disps.ads new file mode 100644 index 0000000..fdd648f --- /dev/null +++ b/ortho/mcode/ortho_code-disps.ads @@ -0,0 +1,24 @@ +-- Mcode back-end for ortho - Internal tree dumper. +-- 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 Ortho_Code.Exprs; use Ortho_Code.Exprs; + +package Ortho_Code.Disps is + procedure Disp_Subprg (Subprg : Subprogram_Data_Acc); + procedure Init; + procedure Finish; +end Ortho_Code.Disps; diff --git a/ortho/mcode/ortho_code-dwarf.adb b/ortho/mcode/ortho_code-dwarf.adb new file mode 100644 index 0000000..6f807d0 --- /dev/null +++ b/ortho/mcode/ortho_code-dwarf.adb @@ -0,0 +1,1344 @@ +-- 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; +with Binary_File; use Binary_File; + +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_None); + 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_None); + 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_None); + 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_None); + 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)"); + declare + Dir : String := GNAT.Directory_Operations.Get_Current_Dir; + begin + Gen_String_Nul (Dir); + end; + end Init; + + procedure Emit_Decl (Decl : O_Dnode); + + 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; + begin + Set_Symbol_Pc (End_Sym, False); + Length := Get_Current_Pc; + + Emit_Decls_Until (Decls.Get_Decl_Last); + + -- 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_None); + 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; + 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); + 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 (Int32 (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); + 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; + diff --git a/ortho/mcode/ortho_code-dwarf.ads b/ortho/mcode/ortho_code-dwarf.ads new file mode 100644 index 0000000..bdd07eb --- /dev/null +++ b/ortho/mcode/ortho_code-dwarf.ads @@ -0,0 +1,38 @@ +-- 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. +package Ortho_Code.Dwarf is + procedure Init; + procedure Finish; + + -- For a body. + procedure Emit_Subprg (Bod : O_Dnode); + + -- For a line in a subprogram. + procedure Set_Line_Stmt (Line : Int32); + procedure Set_Filename (Dir : String; File : String); + + type Mark_Type is limited private; + procedure Mark (M : out Mark_Type); + procedure Release (M : Mark_Type); + +private + type Mark_Type is record + Last_Decl : O_Dnode; + Last_Tnode : O_Tnode; + end record; +end Ortho_Code.Dwarf; diff --git a/ortho/mcode/ortho_code-exprs.adb b/ortho/mcode/ortho_code-exprs.adb new file mode 100644 index 0000000..b8da44c --- /dev/null +++ b/ortho/mcode/ortho_code-exprs.adb @@ -0,0 +1,1656 @@ +-- Mcode back-end for ortho - Expressions and control handling. +-- 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 Ada.Text_IO; +with Ada.Unchecked_Deallocation; +with GNAT.Table; +with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Consts; use Ortho_Code.Consts; +with Ortho_Code.Decls; use Ortho_Code.Decls; +with Ortho_Code.Debug; use Ortho_Code.Debug; +with Ortho_Code.Abi; +with Ortho_Code.Disps; +with Ortho_Code.Opts; +with Ortho_Code.Flags; + +package body Ortho_Code.Exprs is + + type Enode_Pad is mod 256; + + type Enode_Common is record + Kind : OE_Kind; -- about 1 byte (6 bits) + Reg : O_Reg; -- 1 byte + Mode : Mode_Type; -- 4 bits + Ref : Boolean; + Flag1 : Boolean; + Flag2 : Boolean; + Flag3 : Boolean; + Pad : Enode_Pad; + Arg1 : O_Enode; + Arg2 : O_Enode; + Info : Int32; + end record; + pragma Pack (Enode_Common); + for Enode_Common'Size use 4*32; + for Enode_Common'Alignment use 4; + + package Enodes is new GNAT.Table + (Table_Component_Type => Enode_Common, + Table_Index_Type => O_Enode, + Table_Low_Bound => 2, + Table_Initial => 1024, + Table_Increment => 100); + + function Get_Expr_Kind (Enode : O_Enode) return OE_Kind is + begin + return Enodes.Table (Enode).Kind; + end Get_Expr_Kind; + + function Get_Expr_Mode (Enode : O_Enode) return Mode_Type is + begin + return Enodes.Table (Enode).Mode; + end Get_Expr_Mode; + + function Get_Enode_Type (Enode : O_Enode) return O_Tnode is + begin + return O_Tnode (Enodes.Table (Enode).Info); + end Get_Enode_Type; + + function Get_Expr_Reg (Enode : O_Enode) return O_Reg is + begin + return Enodes.Table (Enode).Reg; + end Get_Expr_Reg; + + procedure Set_Expr_Reg (Enode : O_Enode; Reg : O_Reg) is + begin + Enodes.Table (Enode).Reg := Reg; + end Set_Expr_Reg; + + function Get_Expr_Operand (Enode : O_Enode) return O_Enode is + begin + return Enodes.Table (Enode).Arg1; + end Get_Expr_Operand; + + procedure Set_Expr_Operand (Enode : O_Enode; Val : O_Enode) is + begin + Enodes.Table (Enode).Arg1 := Val; + end Set_Expr_Operand; + + function Get_Expr_Left (Enode : O_Enode) return O_Enode is + begin + return Enodes.Table (Enode).Arg1; + end Get_Expr_Left; + + function Get_Expr_Right (Enode : O_Enode) return O_Enode is + begin + return Enodes.Table (Enode).Arg2; + end Get_Expr_Right; + + procedure Set_Expr_Left (Enode : O_Enode; Val : O_Enode) is + begin + Enodes.Table (Enode).Arg1 := Val; + end Set_Expr_Left; + + procedure Set_Expr_Right (Enode : O_Enode; Val : O_Enode) is + begin + Enodes.Table (Enode).Arg2 := Val; + end Set_Expr_Right; + + function Get_Expr_Low (Cst : O_Enode) return Uns32 is + begin + return To_Uns32 (Int32 (Enodes.Table (Cst).Arg1)); + end Get_Expr_Low; + + function Get_Expr_High (Cst : O_Enode) return Uns32 is + begin + return To_Uns32 (Int32 (Enodes.Table (Cst).Arg2)); + end Get_Expr_High; + + function Get_Assign_Target (Enode : O_Enode) return O_Enode is + begin + return Enodes.Table (Enode).Arg2; + end Get_Assign_Target; + + procedure Set_Assign_Target (Enode : O_Enode; Targ : O_Enode) is + begin + Enodes.Table (Enode).Arg2 := Targ; + end Set_Assign_Target; + + function Get_Expr_Lit (Lit : O_Enode) return O_Cnode is + begin + return O_Cnode (Enodes.Table (Lit).Arg1); + end Get_Expr_Lit; + + function Get_Conv_Type (Enode : O_Enode) return O_Tnode is + begin + return O_Tnode (Enodes.Table (Enode).Arg2); + end Get_Conv_Type; + + -- Leave node corresponding to the entry. + function Get_Entry_Leave (Enode : O_Enode) return O_Enode is + begin + return Enodes.Table (Enode).Arg1; + end Get_Entry_Leave; + + procedure Set_Entry_Leave (Enode : O_Enode; Leave : O_Enode) is + begin + Enodes.Table (Enode).Arg1 := Leave; + end Set_Entry_Leave; + + function Get_Jump_Label (Enode : O_Enode) return O_Enode is + begin + return Enodes.Table (Enode).Arg2; + end Get_Jump_Label; + + procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode) is + begin + Enodes.Table (Enode).Arg2 := Label; + end Set_Jump_Label; + + function Get_Addr_Object (Enode : O_Enode) return O_Dnode is + begin + return O_Dnode (Enodes.Table (Enode).Arg1); + end Get_Addr_Object; + + function Get_Addrl_Frame (Enode : O_Enode) return O_Enode is + begin + return Enodes.Table (Enode).Arg2; + end Get_Addrl_Frame; + + procedure Set_Addrl_Frame (Enode : O_Enode; Frame : O_Enode) is + begin + Enodes.Table (Enode).Arg2 := Frame; + end Set_Addrl_Frame; + + function Get_Call_Subprg (Enode : O_Enode) return O_Dnode is + begin + return O_Dnode (Enodes.Table (Enode).Arg1); + end Get_Call_Subprg; + + function Get_Arg_Link (Enode : O_Enode) return O_Enode is + begin + return Enodes.Table (Enode).Arg2; + end Get_Arg_Link; + + function Get_Block_Decls (Blk : O_Enode) return O_Dnode is + begin + return O_Dnode (Enodes.Table (Blk).Arg2); + end Get_Block_Decls; + + function Get_Block_Parent (Blk : O_Enode) return O_Enode is + begin + return Enodes.Table (Blk).Arg1; + end Get_Block_Parent; + + function Get_Block_Has_Alloca (Blk : O_Enode) return Boolean is + begin + return Enodes.Table (Blk).Flag1; + end Get_Block_Has_Alloca; + + procedure Set_Block_Has_Alloca (Blk : O_Enode; Flag : Boolean) is + begin + Enodes.Table (Blk).Flag1 := Flag; + end Set_Block_Has_Alloca; + + function Get_End_Beg (Blk : O_Enode) return O_Enode is + begin + return Enodes.Table (Blk).Arg1; + end Get_End_Beg; + + function Get_Label_Info (Label : O_Enode) return Int32 is + begin + return Int32 (Enodes.Table (Label).Arg2); + end Get_Label_Info; + + procedure Set_Label_Info (Label : O_Enode; Info : Int32) is + begin + Enodes.Table (Label).Arg2 := O_Enode (Info); + end Set_Label_Info; + + function Get_Label_Block (Label : O_Enode) return O_Enode is + begin + return Enodes.Table (Label).Arg1; + end Get_Label_Block; + + function Get_Spill_Info (Spill : O_Enode) return Int32 is + begin + return Int32 (Enodes.Table (Spill).Arg2); + end Get_Spill_Info; + + procedure Set_Spill_Info (Spill : O_Enode; Info : Int32) is + begin + Enodes.Table (Spill).Arg2 := O_Enode (Info); + end Set_Spill_Info; + + -- Get the statement link. + function Get_Stmt_Link (Stmt : O_Enode) return O_Enode is + begin + return O_Enode (Enodes.Table (Stmt).Info); + end Get_Stmt_Link; + + procedure Set_Stmt_Link (Stmt : O_Enode; Next : O_Enode) is + begin + Enodes.Table (Stmt).Info := Int32 (Next); + end Set_Stmt_Link; + + function Get_BB_Next (Stmt : O_Enode) return O_Enode is + begin + return Enodes.Table (Stmt).Arg1; + end Get_BB_Next; + + procedure Set_BB_Next (Stmt : O_Enode; Next : O_Enode) is + begin + Enodes.Table (Stmt).Arg1 := Next; + end Set_BB_Next; + + function Get_BB_Number (Stmt : O_Enode) return Int32 is + begin + return Int32 (Enodes.Table (Stmt).Arg2); + end Get_BB_Number; + + procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode) is + begin + Enodes.Table (C).Arg2 := Branch; + end Set_Case_Branch; + + procedure Set_Case_Branch_Choice (Branch : O_Enode; Choice : O_Enode) is + begin + Enodes.Table (Branch).Arg1 := Choice; + end Set_Case_Branch_Choice; + + function Get_Case_Branch_Choice (Branch : O_Enode) return O_Enode is + begin + return Enodes.Table (Branch).Arg1; + end Get_Case_Branch_Choice; + + procedure Set_Case_Choice_Link (Choice : O_Enode; N_Choice : O_Enode) is + begin + Enodes.Table (Choice).Info := Int32 (N_Choice); + end Set_Case_Choice_Link; + + function Get_Case_Choice_Link (Choice : O_Enode) return O_Enode is + begin + return O_Enode (Enodes.Table (Choice).Info); + end Get_Case_Choice_Link; + + function Get_Ref_Field (Ref : O_Enode) return O_Fnode is + begin + return O_Fnode (Enodes.Table (Ref).Arg2); + end Get_Ref_Field; + + function Get_Ref_Index (Ref : O_Enode) return O_Enode is + begin + return Enodes.Table (Ref).Arg2; + end Get_Ref_Index; + + function Get_Expr_Line_Number (Stmt : O_Enode) return Int32 is + begin + return Int32 (Enodes.Table (Stmt).Arg1); + end Get_Expr_Line_Number; + + function Get_Intrinsic_Operation (Stmt : O_Enode) return Int32 is + begin + return Int32 (Enodes.Table (Stmt).Arg1); + end Get_Intrinsic_Operation; + + Last_Stmt : O_Enode := O_Enode_Null; + + procedure Link_Stmt (Stmt : O_Enode) is + begin + if Last_Stmt = O_Enode_Null then + raise Program_Error; + end if; + Set_Stmt_Link (Last_Stmt, Stmt); + Last_Stmt := Stmt; + end Link_Stmt; + + function New_Enode (Kind : OE_Kind; + Rtype : O_Tnode; + Arg1 : O_Enode; + Arg2 : O_Enode) return O_Enode + is + Mode : Mode_Type; + begin + Mode := Get_Type_Mode (Rtype); + Enodes.Append (Enode_Common'(Kind => Kind, + Reg => 0, + Mode => Mode, + Ref => False, + Flag1 => False, + Flag2 => False, + Flag3 => False, + Pad => 0, + Arg1 => Arg1, + Arg2 => Arg2, + Info => Int32 (Rtype))); + return Enodes.Last; + end New_Enode; + + function New_Enode (Kind : OE_Kind; + Mode : Mode_Type; + Rtype : O_Tnode; + Arg1 : O_Enode; + Arg2 : O_Enode) return O_Enode + is + begin + Enodes.Append (Enode_Common'(Kind => Kind, + Reg => 0, + Mode => Mode, + Ref => False, + Flag1 => False, + Flag2 => False, + Flag3 => False, + Pad => 0, + Arg1 => Arg1, + Arg2 => Arg2, + Info => Int32 (Rtype))); + return Enodes.Last; + end New_Enode; + + procedure New_Enode_Stmt (Kind : OE_Kind; Arg1 : O_Enode; Arg2 : O_Enode) + is + begin + Enodes.Append (Enode_Common'(Kind => Kind, + Reg => 0, + Mode => Mode_Nil, + Ref => False, + Flag1 => False, + Flag2 => False, + Flag3 => False, + Pad => 0, + Arg1 => Arg1, + Arg2 => Arg2, + Info => 0)); + Link_Stmt (Enodes.Last); + end New_Enode_Stmt; + + procedure New_Enode_Stmt + (Kind : OE_Kind; Mode : Mode_Type; Arg1 : O_Enode; Arg2 : O_Enode) + is + begin + Enodes.Append (Enode_Common'(Kind => Kind, + Reg => 0, + Mode => Mode, + Ref => False, + Flag1 => False, + Flag2 => False, + Flag3 => False, + Pad => 0, + Arg1 => Arg1, + Arg2 => Arg2, + Info => 0)); + Link_Stmt (Enodes.Last); + end New_Enode_Stmt; + + Bb_Num : Int32 := 0; + Last_Bb : O_Enode := O_Enode_Null; + + procedure Create_BB is + begin + New_Enode_Stmt (OE_BB, Mode_Nil, O_Enode_Null, O_Enode (Bb_Num)); + if Last_Bb /= O_Enode_Null then + Set_BB_Next (Last_Bb, Enodes.Last); + end if; + Last_Bb := Enodes.Last; + Bb_Num := Bb_Num + 1; + end Create_BB; + + procedure Start_BB is + begin + if Flags.Flag_Opt_BB then + Create_BB; + end if; + end Start_BB; + pragma Inline (Start_BB); + + procedure Check_Ref (E : O_Enode) is + begin + if Enodes.Table (E).Ref then + raise Syntax_Error; + end if; + Enodes.Table (E).Ref := True; + end Check_Ref; + + procedure Check_Ref (E : O_Lnode) is + begin + Check_Ref (O_Enode (E)); + end Check_Ref; + + procedure Check_Value_Type (Val : O_Enode; Vtype : O_Tnode) is + begin + if Get_Enode_Type (Val) /= Vtype then + raise Syntax_Error; + end if; + end Check_Value_Type; + + function New_Const_U32 (Val : Uns32; Vtype : O_Tnode) return O_Enode + is + begin + return New_Enode (OE_Const, Vtype, + O_Enode (To_Int32 (Val)), O_Enode_Null); + end New_Const_U32; + + Last_Decl : O_Dnode := 2; + Cur_Block : O_Enode := O_Enode_Null; + + procedure Start_Declare_Stmt + is + Res : O_Enode; + begin + New_Enode_Stmt (OE_Beg, Cur_Block, O_Enode_Null); + Res := Enodes.Last; + Enodes.Table (Res).Arg2 := O_Enode + (Ortho_Code.Decls.Start_Declare_Stmt); + Cur_Block := Res; + end Start_Declare_Stmt; + + function New_Stack (Rtype : O_Tnode) return O_Enode is + begin + return New_Enode (OE_Get_Stack, Rtype, O_Enode_Null, O_Enode_Null); + end New_Stack; + + procedure New_Stack_Restore (Blk : O_Enode) + is + Save_Asgn : O_Enode; + Save_Var : O_Dnode; + begin + Save_Asgn := Get_Stmt_Link (Blk); + Save_Var := Get_Addr_Object (Get_Assign_Target (Save_Asgn)); + New_Enode_Stmt (OE_Set_Stack, New_Value (New_Obj (Save_Var)), + O_Enode_Null); + end New_Stack_Restore; + + procedure Finish_Declare_Stmt + is + Parent : O_Dnode; + begin + if Get_Block_Has_Alloca (Cur_Block) then + New_Stack_Restore (Cur_Block); + end if; + New_Enode_Stmt (OE_End, Cur_Block, O_Enode_Null); + Cur_Block := Get_Block_Parent (Cur_Block); + if Cur_Block = O_Enode_Null then + Parent := O_Dnode_Null; + else + Parent := Get_Block_Decls (Cur_Block); + end if; + Ortho_Code.Decls.Finish_Declare_Stmt (Parent); + end Finish_Declare_Stmt; + + function New_Label return O_Enode is + begin + return New_Enode (OE_Label, Mode_Nil, O_Tnode_Null, + Cur_Block, O_Enode_Null); + end New_Label; + + procedure Start_Subprogram_Body (Func : O_Dnode) + is + Start : O_Enode; + D_Body : O_Dnode; + Data : Subprogram_Data_Acc; + begin + if Cur_Subprg = null then + Abi.Start_Body (Func); + end if; + + Start := New_Enode (OE_Entry, Mode_Nil, O_Tnode_Null, + Last_Stmt, O_Enode_Null); + D_Body := Decls.Start_Subprogram_Body (Func, Start); + + -- Create the corresponding decl. + Enodes.Table (Start).Arg2 := O_Enode (D_Body); + + -- Create the data record. + Data := new Subprogram_Data'(Parent => Cur_Subprg, + First_Child => null, + Last_Child => null, + Brother => null, + Depth => Get_Decl_Depth (Func), + D_Decl => Func, + E_Entry => Start, + D_Body => D_Body, + Exit_Label => O_Enode_Null, + Last_Stmt => O_Enode_Null, + Stack_Max => 0); + + if not Flag_Debug_Hli then + Data.Exit_Label := New_Label; + end if; + + -- Link the record. + if Cur_Subprg = null then + -- A top-level subprogram. + if First_Subprg = null then + First_Subprg := Data; + else + Last_Subprg.Brother := Data; + end if; + Last_Subprg := Data; + else + -- A nested subprogram. + if Cur_Subprg.First_Child = null then + Cur_Subprg.First_Child := Data; + else + Cur_Subprg.Last_Child.Brother := Data; + end if; + Cur_Subprg.Last_Child := Data; + + -- Also save last_stmt. + Cur_Subprg.Last_Stmt := Last_Stmt; + end if; + + Cur_Subprg := Data; + Last_Stmt := Start; + + Start_Declare_Stmt; + + -- Create a basic block for the beginning of the subprogram. + Start_BB; + + -- Disp declarations. + if Cur_Subprg.Parent = null then + if Ortho_Code.Debug.Flag_Debug_Body + or Ortho_Code.Debug.Flag_Debug_Code + then + while Last_Decl <= D_Body loop + case Get_Decl_Kind (Last_Decl) is + when OD_Block => + -- Skip blocks. + Disp_Decl (1, Last_Decl); + Last_Decl := Get_Block_Last (Last_Decl) + 1; + when others => + Disp_Decl (1, Last_Decl); + Last_Decl := Last_Decl + 1; + end case; + end loop; + end if; + end if; + end Start_Subprogram_Body; + + procedure Finish_Subprogram_Body + is + Parent : Subprogram_Data_Acc; + begin + Finish_Declare_Stmt; + + -- Create a new basic block for the epilog. + Start_BB; + + if not Flag_Debug_Hli then + Link_Stmt (Cur_Subprg.Exit_Label); + end if; + + New_Enode_Stmt (OE_Leave, O_Enode_Null, O_Enode_Null); + + -- Save last statement. + Cur_Subprg.Last_Stmt := Enodes.Last; + -- Set Leave of Entry. + Set_Entry_Leave (Cur_Subprg.E_Entry, Enodes.Last); + + Decls.Finish_Subprogram_Body; + + Parent := Cur_Subprg.Parent; + + if Flags.Flag_Optimize then + Opts.Optimize_Subprg (Cur_Subprg); + end if; + + if Parent = null then + -- This is a top-level subprogram. + if Ortho_Code.Debug.Flag_Disp_Code then + Disps.Disp_Subprg (Cur_Subprg); + end if; + if Ortho_Code.Debug.Flag_Dump_Code then + Disp_Subprg_Body (1, Cur_Subprg.E_Entry); + end if; + if not Ortho_Code.Debug.Flag_Debug_Dump then + Abi.Finish_Body (Cur_Subprg); + end if; + end if; + + -- Restore Cur_Subprg. + Cur_Subprg := Parent; + + -- Restore Last_Stmt. + if Cur_Subprg = null then + Last_Stmt := O_Enode_Null; + else + Last_Stmt := Cur_Subprg.Last_Stmt; + end if; + end Finish_Subprogram_Body; + + function Get_Inner_Alloca (Label : O_Enode) return O_Enode + is + Res : O_Enode := O_Enode_Null; + Blk : O_Enode; + Last_Blk : O_Enode := Get_Label_Block (Label); + begin + Blk := Cur_Block; + while Blk /= Last_Blk loop + if Get_Block_Has_Alloca (Blk) then + Res := Blk; + end if; + Blk := Get_Block_Parent (Blk); + end loop; + return Res; + end Get_Inner_Alloca; + + procedure Emit_Jmp (Code : OE_Kind; Expr : O_Enode; Label : O_Enode) + is + begin + -- Discard jump after jump. + if Code /= OE_Jump or else Get_Expr_Kind (Last_Stmt) /= OE_Jump then + New_Enode_Stmt (Code, Expr, Label); + end if; + end Emit_Jmp; + + + -- If there is stack allocated memory to be freed, free it. + -- Then jump to LABEL. + procedure New_Allocb_Jump (Label : O_Enode) + is + Inner_Alloca : O_Enode; + begin + Inner_Alloca := Get_Inner_Alloca (Label); + if Inner_Alloca /= O_Enode_Null then + New_Stack_Restore (Inner_Alloca); + end if; + Emit_Jmp (OE_Jump, O_Enode_Null, Label); + end New_Allocb_Jump; + + function New_Lit (Lit : O_Cnode) return O_Enode + is + L_Type : O_Tnode; + H, L : Uns32; + begin + L_Type := Get_Const_Type (Lit); + if Flag_Debug_Hli then + return New_Enode (OE_Lit, L_Type, O_Enode (Lit), O_Enode_Null); + else + case Get_Const_Kind (Lit) is + when OC_Signed + | OC_Unsigned + | OC_Float + | OC_Null + | OC_Lit => + Get_Const_Bytes (Lit, H, L); + return New_Enode + (OE_Const, L_Type, + O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H))); + when OC_Address + | OC_Subprg_Address => + return New_Enode (OE_Addrg, L_Type, + O_Enode (Get_Const_Decl (Lit)), O_Enode_Null); + when OC_Array + | OC_Record + | OC_Sizeof => + raise Syntax_Error; + end case; + end if; + end New_Lit; + + function Get_Static_Chain (Depth : O_Depth) return O_Enode + is + Cur_Depth : O_Depth := Cur_Subprg.Depth; + Subprg : Subprogram_Data_Acc; + Res : O_Enode; + begin + if Depth = Cur_Depth then + return New_Enode (OE_Get_Frame, Abi.Mode_Ptr, O_Tnode_Ptr, + O_Enode_Null, O_Enode_Null); + else + Subprg := Cur_Subprg; + Res := O_Enode_Null; + loop + Res := New_Enode (OE_Addrl, Abi.Mode_Ptr, O_Tnode_Ptr, + O_Enode (Subprg.D_Decl + 1), Res); + Res := New_Enode (OE_Indir, O_Tnode_Ptr, Res, O_Enode_Null); + Cur_Depth := Cur_Depth - 1; + if Cur_Depth = Depth then + return Res; + end if; + Subprg := Subprg.Parent; + end loop; + end if; + end Get_Static_Chain; + + function New_Obj (Obj : O_Dnode) return O_Lnode + is + O_Type : O_Tnode; + Kind : OE_Kind; + Chain : O_Enode; + Depth : O_Depth; + begin + O_Type := Get_Decl_Type (Obj); + case Get_Decl_Kind (Obj) is + when OD_Local + | OD_Interface => + Kind := OE_Addrl; + -- Local declarations are 1 deeper than their subprogram. + Depth := Get_Decl_Depth (Obj) - 1; + if Depth /= Cur_Subprg.Depth then + Chain := Get_Static_Chain (Depth); + else + Chain := O_Enode_Null; + end if; + when OD_Var + | OD_Const => + Kind := OE_Addrg; + Chain := O_Enode_Null; + when others => + raise Program_Error; + end case; + return O_Lnode (New_Enode (Kind, Abi.Mode_Ptr, O_Type, + O_Enode (Obj), Chain)); + end New_Obj; + + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode + is + L_Type : O_Tnode; + begin + L_Type := Get_Enode_Type (Left); + if Flag_Debug_Assert then + if L_Type /= Get_Enode_Type (Right) then + raise Syntax_Error; + end if; + if Get_Type_Mode (L_Type) = Mode_Blk then + raise Syntax_Error; + end if; + Check_Ref (Left); + Check_Ref (Right); + end if; + + return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), + L_Type, Left, Right); + end New_Dyadic_Op; + + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode + is + O_Type : O_Tnode; + begin + O_Type := Get_Enode_Type (Operand); + + if Flag_Debug_Assert then + if Get_Type_Mode (O_Type) = Mode_Blk then + raise Syntax_Error; + end if; + Check_Ref (Operand); + end if; + + return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), O_Type, + Operand, O_Enode_Null); + end New_Monadic_Op; + + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) + return O_Enode + is + Res : O_Enode; + begin + if Flag_Debug_Assert then + if Get_Enode_Type (Left) /= Get_Enode_Type (Right) then + raise Syntax_Error; + end if; + if Get_Expr_Mode (Left) = Mode_Blk then + raise Syntax_Error; + end if; + if Get_Type_Kind (Ntype) /= OT_Boolean then + raise Syntax_Error; + end if; + Check_Ref (Left); + Check_Ref (Right); + end if; + + Res := New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), Ntype, + Left, Right); + if Flag_Debug_Hli then + return New_Enode (OE_Typed, Ntype, Res, O_Enode (Ntype)); + else + return Res; + end if; + end New_Compare_Op; + + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Enode is + begin + return New_Const_U32 (Get_Type_Size (Atype), Rtype); + end New_Sizeof; + + function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Enode is + begin + return New_Const_U32 (Get_Field_Offset (Field), Rtype); + end New_Offsetof; + + function Is_Pow2 (V : Uns32) return Boolean is + begin + return (V and -V) = V; + end Is_Pow2; + + function Extract_Pow2 (V : Uns32) return Uns32 is + begin + for I in Natural range 0 .. 31 loop + if V = Shift_Left (1, I) then + return Uns32 (I); + end if; + end loop; + raise Program_Error; + end Extract_Pow2; + + function New_Index_Slice_Element + (Arr : O_Lnode; Index : O_Enode; Res_Type : O_Tnode) + return O_Lnode + is + El_Type : O_Tnode; + In_Type : O_Tnode; + Sz : O_Enode; + El_Size : Uns32; + begin + El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr))); + In_Type := Get_Enode_Type (Index); + + if Flag_Debug_Assert then + Check_Ref (Index); + Check_Ref (Arr); + end if; + + -- result := arr + index * sizeof (element). + El_Size := Get_Type_Size (El_Type); + if El_Size = 1 then + Sz := Index; + elsif Get_Expr_Kind (Index) = OE_Const then + -- FIXME: may recycle previous index? + Sz := New_Const_U32 (Get_Expr_Low (Index) * El_Size, In_Type); + else + if Is_Pow2 (El_Size) then + Sz := New_Const_U32 (Extract_Pow2 (El_Size), In_Type); + Sz := New_Enode (OE_Shl, In_Type, Index, Sz); + else + Sz := New_Const_U32 (El_Size, In_Type); + Sz := New_Enode (OE_Mul, In_Type, Index, Sz); + end if; + end if; + return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type, + O_Enode (Arr), Sz)); + end New_Index_Slice_Element; + + function New_Hli_Index_Slice + (Kind : OE_Kind; Res_Type : O_Tnode; Arr : O_Lnode; Index : O_Enode) + return O_Lnode + is + begin + if Flag_Debug_Assert then + Check_Ref (Index); + Check_Ref (Arr); + end if; + return O_Lnode (New_Enode (Kind, Res_Type, O_Enode (Arr), Index)); + end New_Hli_Index_Slice; + + -- Get an element of an array. + -- INDEX must be of the type of the array index. + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) + return O_Lnode + is + El_Type : O_Tnode; + begin + El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr))); + + if Flag_Debug_Hli then + return New_Hli_Index_Slice (OE_Index_Ref, El_Type, Arr, Index); + else + return New_Index_Slice_Element (Arr, Index, El_Type); + end if; + end New_Indexed_Element; + + -- Get a slice of an array; this is equivalent to a conversion between + -- an array or an array subtype and an array subtype. + -- RES_TYPE must be an array_sub_type whose base type is the same as the + -- base type of ARR. + -- INDEX must be of the type of the array index. + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode + is + begin + if Flag_Debug_Hli then + return New_Hli_Index_Slice (OE_Slice_Ref, Res_Type, Arr, Index); + else + return New_Index_Slice_Element (Arr, Index, Res_Type); + end if; + end New_Slice; + + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode + is + Offset : Uns32; + Off : O_Enode; + Res_Type : O_Tnode; + begin + if Flag_Debug_Assert then + Check_Ref (Rec); + end if; + + Res_Type := Get_Field_Type (El); + if Flag_Debug_Hli then + return O_Lnode (New_Enode (OE_Record_Ref, Res_Type, + O_Enode (Rec), O_Enode (El))); + else + Offset := Get_Field_Offset (El); + if Offset = 0 then + return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type, + O_Enode (Rec), O_Enode (Res_Type))); + else + Off := New_Enode (OE_Const, Mode_U32, O_Tnode_Null, + O_Enode (Offset), O_Enode_Null); + + return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type, + O_Enode (Rec), Off)); + end if; + end if; + end New_Selected_Element; + + function New_Access_Element (Acc : O_Enode) return O_Lnode + is + Acc_Type : O_Tnode; + Res_Type : O_Tnode; + begin + Acc_Type := Get_Enode_Type (Acc); + + if Flag_Debug_Assert then + if Get_Type_Kind (Acc_Type) /= OT_Access then + raise Syntax_Error; + end if; + Check_Ref (Acc); + end if; + + Res_Type := Get_Type_Access_Type (Acc_Type); + if Flag_Debug_Hli then + return O_Lnode (New_Enode (OE_Access_Ref, Abi.Mode_Ptr, Res_Type, + Acc, O_Enode_Null)); + else + return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type, + Acc, O_Enode (Res_Type))); + end if; + end New_Access_Element; + + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is + begin + if Flag_Debug_Assert then + Check_Ref (Val); + end if; + + return New_Enode (OE_Conv, Rtype, Val, O_Enode (Rtype)); + end New_Convert_Ov; + + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode is + begin + if Flag_Debug_Assert then + if Get_Type_Kind (Atype) /= OT_Access then + raise Syntax_Error; + end if; + Check_Ref (Lvalue); + end if; + + return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype, + O_Enode (Lvalue), O_Enode (Atype)); + end New_Unchecked_Address; + + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is + begin + if Flag_Debug_Assert then + if Get_Type_Kind (Atype) /= OT_Access then + raise Syntax_Error; + end if; + Check_Ref (Lvalue); + end if; + + return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype, + O_Enode (Lvalue), O_Enode (Atype)); + end New_Address; + + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Enode is + begin + raise Program_Error; + return O_Enode_Null; + end New_Subprogram_Address; + + function New_Value (Lvalue : O_Lnode) return O_Enode + is + V_Type : O_Tnode; + begin + V_Type := Get_Enode_Type (O_Enode (Lvalue)); + + if Flag_Debug_Assert then + Check_Ref (Lvalue); + end if; + + return New_Enode (OE_Indir, V_Type, O_Enode (Lvalue), O_Enode_Null); + end New_Value; + + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode + is + Save_Var : O_Dnode; + Stmt : O_Enode; + begin + if Flag_Debug_Assert then + Check_Ref (Size); + if Get_Type_Kind (Rtype) /= OT_Access then + raise Syntax_Error; + end if; + if Get_Type_Kind (Get_Enode_Type (Size)) /= OT_Unsigned then + raise Syntax_Error; + end if; + end if; + + if not Get_Block_Has_Alloca (Cur_Block) then + Set_Block_Has_Alloca (Cur_Block, True); + -- Add a decl. + New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, Rtype); + -- Add insn to save stack ptr. + Stmt := New_Enode (OE_Asgn, Rtype, + New_Stack (Rtype), + O_Enode (New_Obj (Save_Var))); + if Cur_Block = Last_Stmt then + Set_Stmt_Link (Last_Stmt, Stmt); + Last_Stmt := Stmt; + else + Set_Stmt_Link (Stmt, Get_Stmt_Link (Cur_Block)); + Set_Stmt_Link (Cur_Block, Stmt); + end if; + end if; + + return New_Enode (OE_Alloca, Rtype, Size, O_Enode (Rtype)); + end New_Alloca; + + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) + is + Depth : O_Depth; + Arg : O_Enode; + First_Inter : O_Dnode; + begin + First_Inter := Get_Subprg_Interfaces (Subprg); + if Get_Decl_Storage (Subprg) = O_Storage_Local then + Depth := Get_Decl_Depth (Subprg); + Arg := New_Enode (OE_Arg, Abi.Mode_Ptr, O_Tnode_Ptr, + Get_Static_Chain (Depth - 1), O_Enode_Null); + First_Inter := Get_Interface_Chain (First_Inter); + else + Arg := O_Enode_Null; + end if; + Assocs := (Subprg => Subprg, + First_Arg => Arg, + Last_Arg => Arg, + Next_Inter => First_Inter); + end Start_Association; + + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) + is + V_Type : O_Tnode; + Mode : Mode_Type; + N_Mode : Mode_Type; + Res : O_Enode; + begin + V_Type := Get_Enode_Type (Val); + + if Flag_Debug_Assert then + if Assocs.Next_Inter = O_Dnode_Null then + -- More assocs than interfaces. + raise Syntax_Error; + end if; + Check_Value_Type (Val, Get_Decl_Type (Assocs.Next_Inter)); + Check_Ref (Val); + end if; + + -- Follow the C convention call: no parameters shorter than int. + Mode := Get_Type_Mode (V_Type); + case Mode is + when Mode_B2 + | Mode_U8 + | Mode_U16 => + N_Mode := Mode_U32; + when Mode_I8 + | Mode_I16 => + N_Mode := Mode_I32; + when Mode_P32 + | Mode_U32 + | Mode_I32 + | Mode_U64 + | Mode_I64 + | Mode_P64 + | Mode_F32 + | Mode_F64 => + N_Mode := Mode; + when Mode_Blk + | Mode_Nil + | Mode_X1 => + raise Program_Error; + end case; + if N_Mode /= Mode and not Flag_Debug_Hli then + Res := New_Enode (OE_Conv, N_Mode, V_Type, Val, O_Enode (V_Type)); + else + Res := Val; + end if; + Res := New_Enode (OE_Arg, N_Mode, V_Type, Res, O_Enode_Null); + if Assocs.Last_Arg /= O_Enode_Null then + Enodes.Table (Assocs.Last_Arg).Arg2 := Res; + else + Assocs.First_Arg := Res; + end if; + Assocs.Last_Arg := Res; + Assocs.Next_Inter := Get_Interface_Chain (Assocs.Next_Inter); + end New_Association; + + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode + is + F_Type : O_Tnode; + begin + if Flag_Debug_Assert then + if Assocs.Next_Inter /= O_Dnode_Null then + -- Not enough assocs. + raise Syntax_Error; + end if; + end if; + + F_Type := Get_Decl_Type (Assocs.Subprg); + return New_Enode (OE_Call, F_Type, + O_Enode (Assocs.Subprg), Assocs.First_Arg); + end New_Function_Call; + + procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is + begin + if Flag_Debug_Assert then + if Assocs.Next_Inter /= O_Dnode_Null then + -- Not enough assocs. + raise Syntax_Error; + end if; + end if; + New_Enode_Stmt (OE_Call, O_Enode (Assocs.Subprg), Assocs.First_Arg); + end New_Procedure_Call; + + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) + is + V_Type : O_Tnode; + begin + V_Type := Get_Enode_Type (Value); + + if Flag_Debug_Assert then + Check_Value_Type (Value, Get_Enode_Type (O_Enode (Target))); + Check_Ref (Value); + Check_Ref (Target); + end if; + + New_Enode_Stmt (OE_Asgn, Get_Type_Mode (V_Type), + Value, O_Enode (Target)); + end New_Assign_Stmt; + + procedure New_Return_Stmt (Value : O_Enode) + is + V_Type : O_Tnode; + begin + V_Type := Get_Enode_Type (Value); + + if Flag_Debug_Assert then + Check_Ref (Value); + Check_Value_Type (Value, Get_Decl_Type (Cur_Subprg.D_Decl)); + end if; + + New_Enode_Stmt (OE_Ret, Get_Type_Mode (V_Type), Value, O_Enode_Null); + if not Flag_Debug_Hli then + New_Allocb_Jump (Cur_Subprg.Exit_Label); + end if; + end New_Return_Stmt; + + procedure New_Return_Stmt is + begin + if Flag_Debug_Assert then + if Get_Decl_Kind (Cur_Subprg.D_Decl) /= OD_Procedure then + raise Syntax_Error; + end if; + end if; + + if not Flag_Debug_Hli then + New_Allocb_Jump (Cur_Subprg.Exit_Label); + else + New_Enode_Stmt (OE_Ret, Mode_Nil, O_Enode_Null, O_Enode_Null); + end if; + end New_Return_Stmt; + + + procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode) is + begin + if Flag_Debug_Assert then + if Get_Expr_Mode (Cond) /= Mode_B2 then + -- COND must be a boolean. + raise Syntax_Error; + end if; + Check_Ref (Cond); + end if; + + if Flag_Debug_Hli then + New_Enode_Stmt (OE_If, Cond, O_Enode_Null); + Block := (Label_End => O_Enode_Null, + Label_Next => Last_Stmt); + else + Block := (Label_End => O_Enode_Null, + Label_Next => New_Label); + Emit_Jmp (OE_Jump_F, Cond, Block.Label_Next); + Start_BB; + end if; + end Start_If_Stmt; + + procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) is + begin + if Flag_Debug_Assert then + if Get_Expr_Mode (Cond) /= Mode_B2 then + -- COND must be a boolean. + raise Syntax_Error; + end if; + Check_Ref (Cond); + end if; + + if Flag_Debug_Hli then + New_Enode_Stmt (OE_Elsif, Cond, O_Enode_Null); + Block.Label_Next := Last_Stmt; + else + if Block.Label_End = O_Enode_Null then + Block.Label_End := New_Label; + end if; + Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); + Start_BB; + Link_Stmt (Block.Label_Next); + Block.Label_Next := New_Label; + Emit_Jmp (OE_Jump_F, Cond, Block.Label_Next); + Start_BB; + end if; + end New_Elsif_Stmt; + + procedure New_Else_Stmt (Block : in out O_If_Block) is + begin + if Flag_Debug_Hli then + New_Enode_Stmt (OE_Elsif, O_Enode_Null, O_Enode_Null); + else + if Block.Label_End = O_Enode_Null then + Block.Label_End := New_Label; + end if; + Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); + Start_BB; + Link_Stmt (Block.Label_Next); + Block.Label_Next := O_Enode_Null; + end if; + end New_Else_Stmt; + + procedure Finish_If_Stmt (Block : in out O_If_Block) is + begin + if Flag_Debug_Hli then + New_Enode_Stmt (OE_Endif, O_Enode_Null, O_Enode_Null); + else + -- Create a badic-block after the IF. + Start_BB; + if Block.Label_Next /= O_Enode_Null then + Link_Stmt (Block.Label_Next); + end if; + if Block.Label_End /= O_Enode_Null then + Link_Stmt (Block.Label_End); + end if; + end if; + end Finish_If_Stmt; + + procedure Start_Loop_Stmt (Label : out O_Snode) is + begin + if Flag_Debug_Hli then + New_Enode_Stmt (OE_Loop, O_Enode_Null, O_Enode_Null); + Label := (Label_Start => Last_Stmt, + Label_End => O_Enode_Null); + else + -- Create a basic-block at the beginning of the loop. + Start_BB; + Label.Label_Start := New_Label; + Link_Stmt (Label.Label_Start); + Label.Label_End := New_Label; + end if; + end Start_Loop_Stmt; + + procedure Finish_Loop_Stmt (Label : in out O_Snode) + is + begin + if Flag_Debug_Hli then + New_Enode_Stmt (OE_Eloop, Label.Label_Start, O_Enode_Null); + else + Emit_Jmp (OE_Jump, O_Enode_Null, Label.Label_Start); + Start_BB; + Link_Stmt (Label.Label_End); + end if; + end Finish_Loop_Stmt; + + + procedure New_Exit_Stmt (L : O_Snode) + is + begin + if Flag_Debug_Hli then + New_Enode_Stmt (OE_Exit, O_Enode_Null, L.Label_Start); + else + New_Allocb_Jump (L.Label_End); + end if; + end New_Exit_Stmt; + + procedure New_Next_Stmt (L : O_Snode) + is + begin + if Flag_Debug_Hli then + New_Enode_Stmt (OE_Next, O_Enode_Null, L.Label_Start); + else + New_Allocb_Jump (L.Label_Start); + end if; + end New_Next_Stmt; + + procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode) + is + V_Type : O_Tnode; + Mode : Mode_Type; + Start : O_Enode; + begin + V_Type := Get_Enode_Type (Value); + Mode := Get_Type_Mode (V_Type); + + if Flag_Debug_Assert then + Check_Ref (Value); + case Mode is + when Mode_U8 .. Mode_U64 + | Mode_I8 .. Mode_I64 + | Mode_B2 => + null; + when others => + raise Syntax_Error; + end case; + end if; + + New_Enode_Stmt (OE_Case, Mode, Value, O_Enode_Null); + Start := Enodes.Last; + if Flag_Debug_Hli then + Block := (Expr => Start, + Expr_Type => V_Type, + Last_Node => O_Enode_Null, + Label_End => O_Enode_Null, + Label_Branch => Start); + else + Block := (Expr => Start, + Expr_Type => V_Type, + Last_Node => Start, + Label_End => New_Label, + Label_Branch => O_Enode_Null); + end if; + end Start_Case_Stmt; + + procedure Start_Choice (Block : in out O_Case_Block) + is + B : O_Enode; + begin + if Flag_Debug_Hli then + B := New_Enode (OE_Case_Branch, Mode_Nil, O_Tnode_Null, + O_Enode_Null, O_Enode_Null); + Link_Stmt (B); + -- Link it. + Set_Case_Branch (Block.Label_Branch, B); + Block.Label_Branch := B; + else + -- Jump to the end of the case statement. + -- If there is already a branch open, this is ok + -- (do not fall-through). + -- If there is no branch open, then this is the default choice + -- (nothing to do). + Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); + + -- Create a label for the code of this branch. + Block.Label_Branch := New_Label; + end if; + end Start_Choice; + + procedure Insert_Choice_Stmt (Block : in out O_Case_Block; Stmt : O_Enode) + is + Prev : O_Enode; + begin + Prev := Get_Stmt_Link (Block.Last_Node); + Set_Stmt_Link (Block.Last_Node, Stmt); + Block.Last_Node := Stmt; + if Prev = O_Enode_Null then + Last_Stmt := Stmt; + else + Set_Stmt_Link (Stmt, Prev); + end if; + end Insert_Choice_Stmt; + + procedure Emit_Choice_Jmp (Block : in out O_Case_Block; + Code : OE_Kind; Expr : O_Enode; Label : O_Enode) + is + Jmp : O_Enode; + begin + Jmp := New_Enode (Code, Mode_Nil, O_Tnode_Null, Expr, Label); + Insert_Choice_Stmt (Block, Jmp); + end Emit_Choice_Jmp; + + -- Create a node containing the value of the case expression. + function New_Case_Expr (Block : O_Case_Block) return O_Enode is + begin + return New_Enode (OE_Case_Expr, Block.Expr_Type, + Block.Expr, O_Enode_Null); + end New_Case_Expr; + + procedure New_Hli_Choice (Block : in out O_Case_Block; + Hi, Lo : O_Enode) + is + Res : O_Enode; + begin + Res := New_Enode (OE_Case_Choice, Mode_Nil, O_Tnode_Null, Hi, Lo); + if Block.Label_End = O_Enode_Null then + Set_Case_Branch_Choice (Block.Label_Branch, Res); + else + Set_Case_Choice_Link (Block.Label_End, Res); + end if; + Block.Label_End := Res; + end New_Hli_Choice; + + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) + is + Res : O_Enode; + begin + if Flag_Debug_Hli then + New_Hli_Choice (Block, New_Lit (Expr), O_Enode_Null); + else + Res := New_Enode (OE_Eq, Mode_B2, O_Tnode_Null, + New_Case_Expr (Block), New_Lit (Expr)); + Emit_Choice_Jmp (Block, OE_Jump_T, Res, Block.Label_Branch); + end if; + end New_Expr_Choice; + + procedure New_Range_Choice (Block : in out O_Case_Block; + Low, High : O_Cnode) + is + E1 : O_Enode; + E2 : O_Enode; + Label : O_Enode; + begin + if Flag_Debug_Hli then + New_Hli_Choice (Block, New_Lit (Low), New_Lit (High)); + else + -- Internal label. + Label := New_Label; + E1 := New_Enode (OE_Lt, Mode_B2, O_Tnode_Null, + New_Case_Expr (Block), New_Lit (Low)); + Emit_Choice_Jmp (Block, OE_Jump_T, E1, Label); + E2 := New_Enode (OE_Le, Mode_B2, O_Tnode_Null, + New_Case_Expr (Block), New_Lit (High)); + Emit_Choice_Jmp (Block, OE_Jump_T, E2, Block.Label_Branch); + Insert_Choice_Stmt (Block, Label); + end if; + end New_Range_Choice; + + procedure New_Default_Choice (Block : in out O_Case_Block) is + begin + if Flag_Debug_Hli then + New_Hli_Choice (Block, O_Enode_Null, O_Enode_Null); + else + -- Jump to the code. + Emit_Choice_Jmp (Block, OE_Jump, O_Enode_Null, Block.Label_Branch); + end if; + end New_Default_Choice; + + procedure Finish_Choice (Block : in out O_Case_Block) is + begin + if Flag_Debug_Hli then + Block.Label_End := O_Enode_Null; + else + -- Put the label of the branch. + Start_BB; + Link_Stmt (Block.Label_Branch); + end if; + end Finish_Choice; + + procedure Finish_Case_Stmt (Block : in out O_Case_Block) is + begin + if Flag_Debug_Hli then + New_Enode_Stmt (OE_Case_End, O_Enode_Null, O_Enode_Null); + else + -- Jump to the end of the case statement. + -- Note: this is not required, since the next instruction is the + -- label. + -- Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End); + + -- Put the label of the end of the case. + Start_BB; + Link_Stmt (Block.Label_End); + Block.Label_End := O_Enode_Null; + end if; + end Finish_Case_Stmt; + + procedure New_Debug_Line_Stmt (Line : Natural) is + begin + New_Enode_Stmt (OE_Line, O_Enode (Line), O_Enode_Null); + end New_Debug_Line_Stmt; + + procedure Disp_Enode (Indent : Natural; N : O_Enode) + is + use Ada.Text_IO; + use Ortho_Code.Debug; + use Ortho_Code.Debug.Int32_IO; + begin + Set_Col (Count (Indent)); + Put (Int32 (N), 0); + Set_Col (Count (Indent + 7)); + Disp_Mode (Get_Expr_Mode (N)); + Put (" "); + Put (OE_Kind'Image (Get_Expr_Kind (N))); + Set_Col (Count (Indent + 25)); +-- Put (Abi.Image_Insn (Get_Expr_Insn (N))); +-- Put (" "); + Put (Abi.Image_Reg (Get_Expr_Reg (N))); + Put (" "); + Put (Int32 (Enodes.Table (N).Arg1), 7); + Put (Int32 (Enodes.Table (N).Arg2), 7); + Put (Enodes.Table (N).Info, 7); + New_Line; + end Disp_Enode; + + procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode) + is + N : O_Enode; + N_Indent : Natural; + begin + N := Subprg; + if Get_Expr_Kind (N) /= OE_Entry then + raise Program_Error; + end if; + -- Display the entry. + Disp_Enode (Indent, N); + -- Display the subprogram, binding. + N_Indent := Indent;-- + 1; + N := N + 1; + loop + case Get_Expr_Kind (N) is + when OE_Entry => + N := Get_Entry_Leave (N) + 1; + when OE_Leave => + Disp_Enode (Indent, N); + exit; + when others => + Disp_Enode (N_Indent, N); + case Get_Expr_Kind (N) is + when OE_Beg => + Disp_Block (N_Indent + 2, + O_Dnode (Enodes.Table (N).Arg2)); + N_Indent := N_Indent + 1; + when OE_End => + N_Indent := N_Indent - 1; + when others => + null; + end case; + N := N + 1; + end case; + end loop; + end Disp_Subprg_Body; + + procedure Disp_All_Enode is + begin + for I in Enodes.First .. Enodes.Last loop + Disp_Enode (1, I); + end loop; + end Disp_All_Enode; + + Max_Enode : O_Enode := O_Enode_Null; + + procedure Mark (M : out Mark_Type) is + begin + M.Enode := Enodes.Last; + end Mark; + + procedure Release (M : Mark_Type) is + begin + Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last); + Enodes.Set_Last (M.Enode); + end Release; + + procedure Disp_Stats + is + use Ada.Text_IO; + begin + Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last); + Put ("Number of Enodes:" & O_Enode'Image (Enodes.Last)); + Put (", max:" & O_Enode'Image (Max_Enode)); + New_Line; + end Disp_Stats; + + procedure Free_Subprogram_Data (Data : in out Subprogram_Data_Acc) + is + procedure Free is new Ada.Unchecked_Deallocation + (Subprogram_Data, Subprogram_Data_Acc); + Ch, N_Ch : Subprogram_Data_Acc; + begin + Ch := Data.First_Child; + while Ch /= null loop + N_Ch := Ch.Brother; + Free_Subprogram_Data (Ch); + Ch := N_Ch; + end loop; + Free (Data); + end Free_Subprogram_Data; + + procedure Finish is + begin + Enodes.Free; + Free_Subprogram_Data (First_Subprg); + end Finish; +end Ortho_Code.Exprs; diff --git a/ortho/mcode/ortho_code-exprs.ads b/ortho/mcode/ortho_code-exprs.ads new file mode 100644 index 0000000..ffff28e --- /dev/null +++ b/ortho/mcode/ortho_code-exprs.ads @@ -0,0 +1,580 @@ +-- Mcode back-end for ortho - Expressions and control handling. +-- 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. +package Ortho_Code.Exprs is + type OE_Kind is + ( + OE_Nil, + + -- Dyadic operations. + -- ARG1 is left, ARG2 is right. + OE_Add_Ov, + OE_Sub_Ov, + OE_Mul_Ov, + OE_Div_Ov, + OE_Rem, + OE_Mod, + + OE_And, + OE_Or, + OE_Xor, + + -- Monadic operations. + -- ARG1 is expression. + OE_Not, + OE_Neg_Ov, + OE_Abs_Ov, + + -- Comparaison. + -- ARG1 is left, ARG2 is right. + OE_Eq, + OE_Neq, + OE_Le, + OE_Lt, + OE_Ge, + OE_Gt, + + -- Without checks, for addresses. + OE_Add, + OE_Mul, + OE_Shl, -- Left shift + + -- A literal. + -- ARG1 is low part, ARG2 is high part. + OE_Const, + + -- Address of a local variable/parameter. + -- ARG1 is object. + -- ARG2 is the frame pointer or O_Enode_Null for current frame pointer. + OE_Addrl, + -- Address of a global variable. + -- ARG1 is object. + OE_Addrg, + + -- Pointer dereference. + -- ARG1 is operand. + OE_Indir, + + -- Conversion. + -- ARG1 is expression. + -- ARG2: type + OE_Conv_Ptr, + OE_Conv, + + -- Typed expression. + OE_Typed, + + -- Local memory allocation. + -- ARG1 is size (in bytes). + OE_Alloca, + + -- Statements. + + -- Subrogram entry. + -- ARG1 is the corresponding Leave (used to skip inner subprograms). + -- ARG2 is unused. + OE_Entry, + -- Subprogram exit. + -- ARG1 and ARG2 are unused. + OE_Leave, + + -- Declaration blocks. + -- ARG1: parent + -- ARG2: corresponding declarations. + OE_Beg, + -- ARG1: corresponding beg + -- ARG2: unsused. + OE_End, + + -- Assignment. + -- ARG1 is value, ARG2 is target (address). + OE_Asgn, + + -- Subprogram calls. + -- ARG1 is value + -- ARG2 is link to the next argument. + OE_Arg, + -- ARG1 is subprogram + -- ARG2 is arguments. + OE_Call, + -- ARG1 is intrinsic operation. + OE_Intrinsic, + + -- Return ARG1 (if not mode_nil) from current subprogram. + -- ARG1: expression. + OE_Ret, + + -- Line number (for debugging). + -- ARG1: line number + OE_Line, + + -- High level instructions. + + -- Basic block. + -- ARG1: next BB + -- ARG2: number + OE_BB, + + -- ARG1 is the literal. + OE_Lit, + -- ARG1: value + -- ARG2: first branch (HLI only). + OE_Case, + -- ARG1: the corresponding OE_Case + OE_Case_Expr, + -- ARG1: left bound + -- ARG2: right bound + -- LINK: choice link + OE_Case_Choice, + -- ARG1: choice link + -- ARG2: next branch + OE_Case_Branch, + -- End of case. + OE_Case_End, + + -- ARG1: the condition + -- ARG2: the elsif/endif chain + OE_If, + OE_Elsif, + OE_Endif, + + OE_Loop, + OE_Eloop, + -- ARG2: loop. + OE_Next, + OE_Exit, + + -- ARG1: the record + -- ARG2: the field + OE_Record_Ref, + + -- ARG1: the expression. + OE_Access_Ref, + + -- ARG1: the array + -- ARG2: the index + OE_Index_Ref, + OE_Slice_Ref, + + -- Low level instructions. + + -- Label. + -- ARG1: current block (used for alloca), only during tree building. + -- ARG2: user info (generally used to store symbol). + OE_Label, + + -- Jump to ARG2. + OE_Jump, + + -- Jump to ARG2 if ARG1 is true/false. + OE_Jump_T, + OE_Jump_F, + + -- Used internally only. + -- ARG2 is info/target, ARG1 is expression (if any). + OE_Spill, + OE_Reload, + OE_Move, + + -- Alloca/allocb handling. + OE_Get_Stack, + OE_Set_Stack, + + -- Get current frame pointer. + OE_Get_Frame, + + -- Additionnal reg + OE_Reg + ); + for OE_Kind'Size use 8; + + subtype OE_Kind_Dyadic is OE_Kind range OE_Add_Ov .. OE_Xor; + subtype OE_Kind_Cmp is OE_Kind range OE_Eq .. OE_Gt; + + + -- BE representation of an instruction. + type O_Insn is mod 256; + + type Subprogram_Data; + type Subprogram_Data_Acc is access Subprogram_Data; + + type Subprogram_Data is record + -- Parent or null if top-level subprogram. + Parent : Subprogram_Data_Acc; + + -- Block in which this subprogram is declared, or o_dnode_null if + -- top-level subprogram. + --Parent_Block : O_Dnode; + + -- First and last child, or null if no children. + First_Child : Subprogram_Data_Acc; + Last_Child : Subprogram_Data_Acc; + + -- Next subprogram at the same depth level. + Brother : Subprogram_Data_Acc; + + -- Depth of the subprogram. + Depth : O_Depth; + + -- Dnode for the declaration. + D_Decl : O_Dnode; + + -- Enode for the Entry. + E_Entry : O_Enode; + + -- Dnode for the Body. + D_Body : O_Dnode; + + -- Label just before leave. + Exit_Label : O_Enode; + + -- Last statement of this subprogram. + Last_Stmt : O_Enode; + + -- Static maximum stack use. + Stack_Max : Uns32; + end record; + + -- Data for the current subprogram. + Cur_Subprg : Subprogram_Data_Acc := null; + + -- First and last (top-level) subprogram. + First_Subprg : Subprogram_Data_Acc := null; + Last_Subprg : Subprogram_Data_Acc := null; + + -- Create a new node. + -- Should be used only by back-end to add internal nodes. + function New_Enode (Kind : OE_Kind; + Mode : Mode_Type; + Rtype : O_Tnode; + Arg1 : O_Enode; + Arg2 : O_Enode) return O_Enode; + + -- Get the kind of ENODE. + function Get_Expr_Kind (Enode : O_Enode) return OE_Kind; + pragma Inline (Get_Expr_Kind); + + -- Get the mode of ENODE. + function Get_Expr_Mode (Enode : O_Enode) return Mode_Type; + pragma Inline (Get_Expr_Mode); + + -- Get/Set the register of ENODE. + function Get_Expr_Reg (Enode : O_Enode) return O_Reg; + procedure Set_Expr_Reg (Enode : O_Enode; Reg : O_Reg); + pragma Inline (Get_Expr_Reg); + pragma Inline (Set_Expr_Reg); + + -- Get the operand of an unary expression. + function Get_Expr_Operand (Enode : O_Enode) return O_Enode; + procedure Set_Expr_Operand (Enode : O_Enode; Val : O_Enode); + + -- Get left/right operand of a binary expression. + function Get_Expr_Left (Enode : O_Enode) return O_Enode; + function Get_Expr_Right (Enode : O_Enode) return O_Enode; + procedure Set_Expr_Left (Enode : O_Enode; Val : O_Enode); + procedure Set_Expr_Right (Enode : O_Enode; Val : O_Enode); + + -- Get the low and high part of an OE_CONST node. + function Get_Expr_Low (Cst : O_Enode) return Uns32; + function Get_Expr_High (Cst : O_Enode) return Uns32; + + -- Get target of the assignment. + function Get_Assign_Target (Enode : O_Enode) return O_Enode; + procedure Set_Assign_Target (Enode : O_Enode; Targ : O_Enode); + + -- For OE_Lit: get the literal. + function Get_Expr_Lit (Lit : O_Enode) return O_Cnode; + + -- Type of a OE_Conv/OE_Nop/OE_Typed + -- Used only for display/debugging purposes. + function Get_Conv_Type (Enode : O_Enode) return O_Tnode; + + -- Leave node corresponding to the entry. + function Get_Entry_Leave (Enode : O_Enode) return O_Enode; + + -- Get the label of a jump/ret + function Get_Jump_Label (Enode : O_Enode) return O_Enode; + procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode); + + -- Get the object of addrl,addrp,addrg + function Get_Addr_Object (Enode : O_Enode) return O_Dnode; + + -- Get the computed frame for the object. + -- If O_Enode_Null, then use current frame. + function Get_Addrl_Frame (Enode : O_Enode) return O_Enode; + procedure Set_Addrl_Frame (Enode : O_Enode; Frame : O_Enode); + + -- Get the subprogram called by ENODE. + function Get_Call_Subprg (Enode : O_Enode) return O_Dnode; + + -- Get the first argument of a call, or the next argument of an arg. + function Get_Arg_Link (Enode : O_Enode) return O_Enode; + + -- Get the declaration chain of a Beg statement. + function Get_Block_Decls (Blk : O_Enode) return O_Dnode; + + -- Get the parent of the block. + function Get_Block_Parent (Blk : O_Enode) return O_Enode; + + -- Get the corresponding beg. + function Get_End_Beg (Blk : O_Enode) return O_Enode; + + -- True if the block contains an alloca insn. + function Get_Block_Has_Alloca (Blk : O_Enode) return Boolean; + + -- Set the next branch of a case/case_branch. + procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode); + + -- Set the first choice of a case branch. + procedure Set_Case_Branch_Choice (Branch : O_Enode; Choice : O_Enode); + function Get_Case_Branch_Choice (Branch : O_Enode) return O_Enode; + + -- Set the choice link of a case choice. + procedure Set_Case_Choice_Link (Choice : O_Enode; N_Choice : O_Enode); + function Get_Case_Choice_Link (Choice : O_Enode) return O_Enode; + + -- Get/Set the max stack size for the end block BLKE. + --function Get_Block_Max_Stack (Blke : O_Enode) return Int32; + --procedure Set_Block_Max_Stack (Blke : O_Enode; Max : Int32); + + -- Get the field of an o_record_ref node. + function Get_Ref_Field (Ref : O_Enode) return O_Fnode; + + -- Get the index of an OE_Index_Ref or OE_Slice_Ref node. + function Get_Ref_Index (Ref : O_Enode) return O_Enode; + + -- Get/Set the info field of a label. + function Get_Label_Info (Label : O_Enode) return Int32; + procedure Set_Label_Info (Label : O_Enode; Info : Int32); + + -- Get the info of a spill. + function Get_Spill_Info (Spill : O_Enode) return Int32; + procedure Set_Spill_Info (Spill : O_Enode; Info : Int32); + + -- Get the statement link. + function Get_Stmt_Link (Stmt : O_Enode) return O_Enode; + procedure Set_Stmt_Link (Stmt : O_Enode; Next : O_Enode); + + -- Get the line number of an OE_Line statement. + function Get_Expr_Line_Number (Stmt : O_Enode) return Int32; + + -- Get the operation of an intrinsic. + function Get_Intrinsic_Operation (Stmt : O_Enode) return Int32; + + -- Get the basic block label (uniq number). + function Get_BB_Number (Stmt : O_Enode) return Int32; + + -- Start a subprogram body. + -- Note: the declaration may have an external storage, in this case it + -- becomes public. + procedure Start_Subprogram_Body (Func : O_Dnode); + + -- Finish a subprogram body. + procedure Finish_Subprogram_Body; + + -- Translate a scalar literal into an expression. + function New_Lit (Lit : O_Cnode) return O_Enode; + + -- Translate an object (var, const or interface) into an lvalue. + function New_Obj (Obj : O_Dnode) return O_Lnode; + + -- Create a dyadic operation. + -- Left and right nodes must have the same type. + -- Binary operation is allowed only on boolean types. + -- The result is of the type of the operands. + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode; + + -- Create a monadic operation. + -- Result is of the type of operand. + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode; + + -- Create a comparaison operator. + -- NTYPE is the type of the result and must be a boolean type. + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) + return O_Enode; + + -- Returns the size in bytes of ATYPE. The result is a literal of + -- unsigned type RTYPE + -- ATYPE cannot be an unconstrained array type. + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Enode; + + -- Returns the offset of FIELD in its record. The result is a literal + -- of unsigned type RTYPE. + function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Enode; + + -- Get an element of an array. + -- INDEX must be of the type of the array index. + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) + return O_Lnode; + + -- Get a slice of an array; this is equivalent to a conversion between + -- an array or an array subtype and an array subtype. + -- RES_TYPE must be an array_sub_type whose base type is the same as the + -- base type of ARR. + -- INDEX must be of the type of the array index. + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode; + + -- Get an element of a record. + -- Type of REC must be a record type. + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode; + + -- Reference an access. + -- Type of ACC must be an access type. + function New_Access_Element (Acc : O_Enode) return O_Lnode; + + -- Do a conversion. + -- Allowed conversions are: + -- FIXME: to write. + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode; + + -- Get the address of LVALUE. + -- ATYPE must be a type access whose designated type is the type of LVALUE. + -- FIXME: what about arrays. + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode; + + -- Same as New_Address but without any restriction. + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode; + + -- Get the address of a subprogram. + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Enode; + + -- Get the value of an Lvalue. + function New_Value (Lvalue : O_Lnode) return O_Enode; + + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode; + + type O_Assoc_List is limited private; + + -- Create a function call or a procedure call. + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode); + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode); + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode; + procedure New_Procedure_Call (Assocs : in out O_Assoc_List); + + -- Assign VALUE to TARGET, type must be the same or compatible. + -- FIXME: what about slice assignment? + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode); + + -- Exit from the subprogram and return VALUE. + procedure New_Return_Stmt (Value : O_Enode); + -- Exit from the subprogram, which doesn't return value. + procedure New_Return_Stmt; + + type O_If_Block is limited private; + + -- Build an IF statement. + procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode); + -- COND is NULL for the final else statement. + procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode); + procedure New_Else_Stmt (Block : in out O_If_Block); + procedure Finish_If_Stmt (Block : in out O_If_Block); + + type O_Snode is private; + O_Snode_Null : constant O_Snode; + + -- Create a infinite loop statement. + procedure Start_Loop_Stmt (Label : out O_Snode); + procedure Finish_Loop_Stmt (Label : in out O_Snode); + + -- Exit from a loop stmt or from a for stmt. + procedure New_Exit_Stmt (L : O_Snode); + -- Go to the start of a loop stmt or of a for stmt. + -- Loops/Fors between L and the current points are exited. + procedure New_Next_Stmt (L : O_Snode); + + -- Case statement. + -- VALUE is the selector and must be a discrete type. + type O_Case_Block is limited private; + procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode); + procedure Start_Choice (Block : in out O_Case_Block); + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode); + procedure New_Range_Choice (Block : in out O_Case_Block; + Low, High : O_Cnode); + procedure New_Default_Choice (Block : in out O_Case_Block); + procedure Finish_Choice (Block : in out O_Case_Block); + procedure Finish_Case_Stmt (Block : in out O_Case_Block); + + procedure Start_Declare_Stmt; + procedure Finish_Declare_Stmt; + + procedure New_Debug_Line_Stmt (Line : Natural); + + procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode); + procedure Disp_All_Enode; + procedure Disp_Stats; + + type Mark_Type is limited private; + procedure Mark (M : out Mark_Type); + procedure Release (M : Mark_Type); + + procedure Finish; +private + type O_Assoc_List is record + -- Subprogram being called. + Subprg : O_Dnode; + -- First and last argument statement. + First_Arg : O_Enode; + Last_Arg : O_Enode; + -- Interface for the next association. + Next_Inter : O_Dnode; + end record; + + type O_Case_Block is record + -- Expression for the selection. + Expr : O_Enode; + + -- Type of expression. + -- Used to perform checks. + Expr_Type : O_Tnode; + + -- Choice code and branch code is not mixed (anymore). + -- Therefore, code to perform choices is inserted. + -- Last node of the choice code. + Last_Node : O_Enode; + + -- Label at the end of the case statement. + -- used to jump from the end of a branch to the end of the statement. + Label_End : O_Enode; + + -- Label of the branch code. + Label_Branch : O_Enode; + end record; + + type O_If_Block is record + Label_End : O_Enode; + Label_Next : O_Enode; + end record; + + type O_Snode is record + Label_Start : O_Enode; + Label_End : O_Enode; + end record; + O_Snode_Null : constant O_Snode := (Label_Start => O_Enode_Null, + Label_End => O_Enode_Null); + + type Mark_Type is record + Enode : O_Enode; + end record; +end Ortho_Code.Exprs; diff --git a/ortho/mcode/ortho_code-flags.ads b/ortho/mcode/ortho_code-flags.ads new file mode 100644 index 0000000..805f377 --- /dev/null +++ b/ortho/mcode/ortho_code-flags.ads @@ -0,0 +1,35 @@ +-- Compile flags for mcode. +-- 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. +package Ortho_Code.Flags is + type Debug_Type is (Debug_None, Debug_Dwarf); + + -- Debugging information generated. + Flag_Debug : Debug_Type := Debug_None; + + -- If set, generate a map from type to type declaration. + Flag_Type_Name : Boolean := False; + + -- If set, enable optimiztions. + Flag_Optimize : Boolean := False; + + -- If set, create basic blocks during tree building. + Flag_Opt_BB : Boolean := False; + + -- If set, add profiling calls. + Flag_Profile : Boolean := False; +end Ortho_Code.Flags; diff --git a/ortho/mcode/ortho_code-opts.adb b/ortho/mcode/ortho_code-opts.adb new file mode 100644 index 0000000..75fedd0 --- /dev/null +++ b/ortho/mcode/ortho_code-opts.adb @@ -0,0 +1,213 @@ +-- Mcode back-end for ortho - Optimization. +-- 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 Ortho_Code.Flags; + +package body Ortho_Code.Opts is + procedure Relabel_Jump (Jmp : O_Enode) + is + Label : O_Enode; + Bb : O_Enode; + begin + Label := Get_Jump_Label (Jmp); + if Get_Expr_Kind (Label) = OE_Label then + Bb := O_Enode (Get_Label_Info (Label)); + if Bb /= O_Enode_Null then + Set_Jump_Label (Jmp, Bb); + end if; + end if; + end Relabel_Jump; + + procedure Jmp_To_Bb (Subprg : Subprogram_Data_Acc) + is + First : O_Enode; + Stmt : O_Enode; + Prev : O_Enode; + Cur_Bb : O_Enode; + begin + -- Get first statement after entry. + First := Get_Stmt_Link (Subprg.E_Entry); + + -- First loop: + -- If a label belongs to a BB (ie, is at the beginning of a BB), + -- then link it to the BB. + Stmt := First; + Cur_Bb := O_Enode_Null; + loop + case Get_Expr_Kind (Stmt) is + when OE_Leave => + exit; + when OE_BB => + Cur_Bb := Stmt; + when OE_Label => + if Cur_Bb /= O_Enode_Null then + Set_Label_Info (Stmt, Int32 (Cur_Bb)); + end if; + when OE_Jump + | OE_Jump_T + | OE_Jump_F => + -- This handles backward jump. + Relabel_Jump (Stmt); + when others => + Cur_Bb := O_Enode_Null; + end case; + Stmt := Get_Stmt_Link (Stmt); + end loop; + + -- Second loop: + -- Transform jump to label to jump to BB. + Stmt := First; + Prev := O_Enode_Null; + loop + case Get_Expr_Kind (Stmt) is + when OE_Leave => + exit; + when OE_Jump + | OE_Jump_T + | OE_Jump_F => + -- This handles forward jump. + Relabel_Jump (Stmt); + -- Update PREV. + Prev := Stmt; + when OE_Label => + -- Remove the Label. + -- Do not update PREV. + if Get_Label_Info (Stmt) /= 0 then + Set_Stmt_Link (Prev, Get_Stmt_Link (Stmt)); + end if; + when others => + Prev := Stmt; + end case; + Stmt := Get_Stmt_Link (Stmt); + end loop; + end Jmp_To_Bb; + + type Oe_Kind_Bool_Array is array (OE_Kind) of Boolean; + Is_Passive_Stmt : constant Oe_Kind_Bool_Array := + (OE_Label | OE_BB | OE_End | OE_Beg => True, + others => False); + + -- Return the next statement after STMT which really execute instructions. + function Get_Fall_Stmt (Stmt : O_Enode) return O_Enode + is + Res : O_Enode; + begin + Res := Stmt; + loop + Res := Get_Stmt_Link (Res); + case Get_Expr_Kind (Res) is + when OE_Label + | OE_BB + | OE_End + | OE_Beg => + null; + when others => + return Res; + end case; + end loop; + end Get_Fall_Stmt; + + procedure Thread_Jump (Subprg : Subprogram_Data_Acc) + is + First : O_Enode; + Stmt : O_Enode; + Prev, Next : O_Enode; + Kind : OE_Kind; + begin + -- Get first statement after entry. + First := Get_Stmt_Link (Subprg.E_Entry); + + -- First loop: + -- If a label belongs to a BB (ie, is at the beginning of a BB), + -- then link it to the BB. + Stmt := First; + Prev := O_Enode_Null; + loop + Next := Get_Stmt_Link (Stmt); + Kind := Get_Expr_Kind (Stmt); + case Kind is + when OE_Leave => + exit; + when OE_Jump => + -- Remove the jump if followed by the label. + -- * For _T/_F: should convert to a ignore value. + -- Discard unreachable statements after the jump. + declare + N_Stmt : O_Enode; + P_Stmt : O_Enode; + Label : O_Enode; + Flag_Discard : Boolean; + K_Stmt : OE_Kind; + begin + N_Stmt := Next; + P_Stmt := Stmt; + Label := Get_Jump_Label (Stmt); + Flag_Discard := Kind = OE_Jump; + loop + if N_Stmt = Label then + -- Remove STMT. + Set_Stmt_Link (Prev, Next); + exit; + end if; + K_Stmt := Get_Expr_Kind (N_Stmt); + if K_Stmt = OE_Label then + -- Do not discard anymore statements, since they are + -- now reachable. + Flag_Discard := False; + end if; + if not Is_Passive_Stmt (K_Stmt) then + if not Flag_Discard then + -- We have found the next statement. + -- Keep the jump. + Prev := Stmt; + exit; + else + -- Delete insn. + N_Stmt := Get_Stmt_Link (N_Stmt); + Set_Stmt_Link (P_Stmt, N_Stmt); + end if; + else + -- Iterate. + P_Stmt := N_Stmt; + N_Stmt := Get_Stmt_Link (N_Stmt); + end if; + end loop; + end; + when others => + Prev := Stmt; + end case; + Stmt := Next; + end loop; + end Thread_Jump; + + procedure Optimize_Subprg (Subprg : Subprogram_Data_Acc) + is + begin + -- Jump optimisation: + -- * discard insns after a OE_JUMP. + -- * Remove jump if followed by label + -- (through label, BB, comments, end, line) + -- * Redirect jump to jump (infinite loop !) + -- * Revert jump_t/f if expr is not (XXX) + -- * Jmp_t/f L:; jmp L2; L1: -> jmp_f/t L2 + Thread_Jump (Subprg); + if Flags.Flag_Opt_BB then + Jmp_To_Bb (Subprg); + end if; + end Optimize_Subprg; +end Ortho_Code.Opts; + diff --git a/ortho/mcode/ortho_code-opts.ads b/ortho/mcode/ortho_code-opts.ads new file mode 100644 index 0000000..27a907c --- /dev/null +++ b/ortho/mcode/ortho_code-opts.ads @@ -0,0 +1,22 @@ +-- Mcode back-end for ortho - Optimization. +-- 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 Ortho_Code.Exprs; use Ortho_Code.Exprs; + +package Ortho_Code.Opts is + procedure Optimize_Subprg (Subprg : Subprogram_Data_Acc); +end Ortho_Code.Opts; diff --git a/ortho/mcode/ortho_code-types.adb b/ortho/mcode/ortho_code-types.adb new file mode 100644 index 0000000..446fde6 --- /dev/null +++ b/ortho/mcode/ortho_code-types.adb @@ -0,0 +1,674 @@ +-- Mcode back-end for ortho - type handling. +-- 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 Ada.Text_IO; +with Ada.Unchecked_Conversion; +with GNAT.Table; +with Ada.Text_IO; +with Ortho_Code.Consts; use Ortho_Code.Consts; +with Ortho_Code.Debug; +with Ortho_Code.Abi; use Ortho_Code.Abi; + +package body Ortho_Code.Types is + type Bool_Array is array (Natural range <>) of Boolean; + pragma Pack (Bool_Array); + + type Tnode_Common is record + Kind : OT_Kind; -- 4 bits. + Mode : Mode_Type; -- 4 bits. + Align : Small_Natural; -- 2 bits. + Pad0 : Bool_Array (0 .. 21); + Size : Uns32; + end record; + pragma Pack (Tnode_Common); + + type Tnode_Access is record + Dtype : O_Tnode; + Pad : Uns32; + end record; + + type Tnode_Array is record + Element_Type : O_Tnode; + Index_Type : O_Tnode; + end record; + + type Tnode_Subarray is record + Base_Type : O_Tnode; + Length : Uns32; + end record; + + type Tnode_Record is record + Fields : O_Fnode; + Nbr_Fields : Uns32; + end record; + + type Tnode_Enum is record + Lits : O_Cnode; + Nbr_Lits : Uns32; + end record; + + type Tnode_Bool is record + Lit_False : O_Cnode; + Lit_True : O_Cnode; + end record; + + package Tnodes is new GNAT.Table + (Table_Component_Type => Tnode_Common, + Table_Index_Type => O_Tnode, + Table_Low_Bound => O_Tnode_First, + Table_Initial => 128, + Table_Increment => 100); + + type Field_Type is record + Ident : O_Ident; + Ftype : O_Tnode; + Offset : Uns32; + Next : O_Fnode; + end record; + + package Fnodes is new GNAT.Table + (Table_Component_Type => Field_Type, + Table_Index_Type => O_Fnode, + Table_Low_Bound => 2, + Table_Initial => 64, + Table_Increment => 100); + + function Get_Type_Kind (Atype : O_Tnode) return OT_Kind is + begin + return Tnodes.Table (Atype).Kind; + end Get_Type_Kind; + + function Get_Type_Size (Atype : O_Tnode) return Uns32 is + begin + return Tnodes.Table (Atype).Size; + end Get_Type_Size; + + function Get_Type_Align (Atype : O_Tnode) return Small_Natural is + begin + return Tnodes.Table (Atype).Align; + end Get_Type_Align; + + function Get_Type_Align_Byte (Atype : O_Tnode) return Uns32 is + begin + return 2 ** Get_Type_Align (Atype); + end Get_Type_Align_Byte; + + function Get_Type_Mode (Atype : O_Tnode) return Mode_Type is + begin + return Tnodes.Table (Atype).Mode; + end Get_Type_Mode; + + function To_Tnode_Access is new Ada.Unchecked_Conversion + (Source => Tnode_Common, Target => Tnode_Access); + + function Get_Type_Access_Type (Atype : O_Tnode) return O_Tnode + is + begin + return To_Tnode_Access (Tnodes.Table (Atype + 1)).Dtype; + end Get_Type_Access_Type; + + + function To_Tnode_Array is new Ada.Unchecked_Conversion + (Source => Tnode_Common, Target => Tnode_Array); + + function Get_Type_Ucarray_Index (Atype : O_Tnode) return O_Tnode is + begin + return To_Tnode_Array (Tnodes.Table (Atype + 1)).Index_Type; + end Get_Type_Ucarray_Index; + + function Get_Type_Ucarray_Element (Atype : O_Tnode) return O_Tnode is + begin + return To_Tnode_Array (Tnodes.Table (Atype + 1)).Element_Type; + end Get_Type_Ucarray_Element; + + + function To_Tnode_Subarray is new Ada.Unchecked_Conversion + (Source => Tnode_Common, Target => Tnode_Subarray); + + function Get_Type_Subarray_Base (Atype : O_Tnode) return O_Tnode is + begin + return To_Tnode_Subarray (Tnodes.Table (Atype + 1)).Base_Type; + end Get_Type_Subarray_Base; + + function Get_Type_Subarray_Length (Atype : O_Tnode) return Uns32 is + begin + return To_Tnode_Subarray (Tnodes.Table (Atype + 1)).Length; + end Get_Type_Subarray_Length; + + + function To_Tnode_Record is new Ada.Unchecked_Conversion + (Source => Tnode_Common, Target => Tnode_Record); + + function Get_Type_Record_Fields (Atype : O_Tnode) return O_Fnode is + begin + return To_Tnode_Record (Tnodes.Table (Atype + 1)).Fields; + end Get_Type_Record_Fields; + + function Get_Type_Record_Nbr_Fields (Atype : O_Tnode) return Uns32 is + begin + return To_Tnode_Record (Tnodes.Table (Atype + 1)).Nbr_Fields; + end Get_Type_Record_Nbr_Fields; + + function To_Tnode_Enum is new Ada.Unchecked_Conversion + (Source => Tnode_Common, Target => Tnode_Enum); + + function Get_Type_Enum_Lits (Atype : O_Tnode) return O_Cnode is + begin + return To_Tnode_Enum (Tnodes.Table (Atype + 1)).Lits; + end Get_Type_Enum_Lits; + + function Get_Type_Enum_Lit (Atype : O_Tnode; Pos : Uns32) return O_Cnode + is + F : O_Cnode; + begin + F := Get_Type_Enum_Lits (Atype); + return F + 2 * O_Cnode (Pos); + end Get_Type_Enum_Lit; + + function Get_Type_Enum_Nbr_Lits (Atype : O_Tnode) return Uns32 is + begin + return To_Tnode_Enum (Tnodes.Table (Atype + 1)).Nbr_Lits; + end Get_Type_Enum_Nbr_Lits; + + + function To_Tnode_Bool is new Ada.Unchecked_Conversion + (Source => Tnode_Common, Target => Tnode_Bool); + + function Get_Type_Bool_False (Atype : O_Tnode) return O_Cnode is + begin + return To_Tnode_Bool (Tnodes.Table (Atype + 1)).Lit_False; + end Get_Type_Bool_False; + + function Get_Type_Bool_True (Atype : O_Tnode) return O_Cnode is + begin + return To_Tnode_Bool (Tnodes.Table (Atype + 1)).Lit_True; + end Get_Type_Bool_True; + + function Get_Field_Offset (Field : O_Fnode) return Uns32 is + begin + return Fnodes.Table (Field).Offset; + end Get_Field_Offset; + + function Get_Field_Type (Field : O_Fnode) return O_Tnode is + begin + return Fnodes.Table (Field).Ftype; + end Get_Field_Type; + + function Get_Field_Ident (Field : O_Fnode) return O_Ident is + begin + return Fnodes.Table (Field).Ident; + end Get_Field_Ident; + + function Get_Field_Chain (Field : O_Fnode) return O_Fnode is + begin + return Field + 1; + end Get_Field_Chain; + + function New_Unsigned_Type (Size : Natural) return O_Tnode + is + Mode : Mode_Type; + Sz : Uns32; + begin + case Size is + when 8 => + Mode := Mode_U8; + Sz := 1; + when 16 => + Mode := Mode_U16; + Sz := 2; + when 32 => + Mode := Mode_U32; + Sz := 4; + when 64 => + Mode := Mode_U64; + Sz := 8; + when others => + raise Program_Error; + end case; + Tnodes.Append (Tnode_Common'(Kind => OT_Unsigned, + Mode => Mode, + Align => Mode_Align (Mode), + Pad0 => (others => False), + Size => Sz)); + return Tnodes.Last; + end New_Unsigned_Type; + + function New_Signed_Type (Size : Natural) return O_Tnode + is + Mode : Mode_Type; + Sz : Uns32; + begin + case Size is + when 8 => + Mode := Mode_I8; + Sz := 1; + when 16 => + Mode := Mode_I16; + Sz := 2; + when 32 => + Mode := Mode_I32; + Sz := 4; + when 64 => + Mode := Mode_I64; + Sz := 8; + when others => + raise Program_Error; + end case; + Tnodes.Append (Tnode_Common'(Kind => OT_Signed, + Mode => Mode, + Align => Mode_Align (Mode), + Pad0 => (others => False), + Size => Sz)); + return Tnodes.Last; + end New_Signed_Type; + + function New_Float_Type return O_Tnode is + begin + Tnodes.Append (Tnode_Common'(Kind => OT_Float, + Mode => Mode_F64, + Align => Mode_Align (Mode_F64), + Pad0 => (others => False), + Size => 8)); + return Tnodes.Last; + end New_Float_Type; + + function To_Tnode_Common is new Ada.Unchecked_Conversion + (Source => Tnode_Enum, Target => Tnode_Common); + + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) + is + Mode : Mode_Type; + Sz : Uns32; + begin + case Size is + when 8 => + Mode := Mode_U8; + Sz := 1; + when 16 => + Mode := Mode_U16; + Sz := 2; + when 32 => + Mode := Mode_U32; + Sz := 4; + when 64 => + Mode := Mode_U64; + Sz := 8; + when others => + raise Program_Error; + end case; + Tnodes.Append (Tnode_Common'(Kind => OT_Enum, + Mode => Mode, + Align => Mode_Align (Mode), + Pad0 => (others => False), + Size => Sz)); + List := (Res => Tnodes.Last, + First => O_Cnode_Null, + Last => O_Cnode_Null, + Nbr => 0); + Tnodes.Increment_Last; + end Start_Enum_Type; + + procedure New_Enum_Literal (List : in out O_Enum_List; + Ident : O_Ident; Res : out O_Cnode) + is + begin + Res := New_Named_Literal (List.Res, Ident, List.Nbr, List.Last); + List.Nbr := List.Nbr + 1; + if List.Last = O_Cnode_Null then + List.First := Res; + end if; + List.Last := Res; + end New_Enum_Literal; + + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is + begin + Res := List.Res; + Tnodes.Table (List.Res + 1) := To_Tnode_Common + (Tnode_Enum'(Lits => List.First, + Nbr_Lits => List.Nbr)); + end Finish_Enum_Type; + + + function To_Tnode_Common is new Ada.Unchecked_Conversion + (Source => Tnode_Bool, Target => Tnode_Common); + + procedure New_Boolean_Type (Res : out O_Tnode; + False_Id : O_Ident; + False_E : out O_Cnode; + True_Id : O_Ident; + True_E : out O_Cnode) + is + begin + Tnodes.Append (Tnode_Common'(Kind => OT_Boolean, + Mode => Mode_B2, + Align => 0, + Pad0 => (others => False), + Size => 1)); + Res := Tnodes.Last; + False_E := New_Named_Literal (Res, False_Id, 0, O_Cnode_Null); + True_E := New_Named_Literal (Res, True_Id, 1, False_E); + Tnodes.Append (To_Tnode_Common (Tnode_Bool'(Lit_False => False_E, + Lit_True => True_E))); + end New_Boolean_Type; + + function To_Tnode_Common is new Ada.Unchecked_Conversion + (Source => Tnode_Array, Target => Tnode_Common); + + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode + is + Res : O_Tnode; + begin + Tnodes.Append (Tnode_Common'(Kind => OT_Ucarray, + Mode => Mode_Blk, + Align => Get_Type_Align (El_Type), + Pad0 => (others => False), + Size => 0)); + Res := Tnodes.Last; + Tnodes.Append (To_Tnode_Common (Tnode_Array'(Element_Type => El_Type, + Index_Type => Index_Type))); + return Res; + end New_Array_Type; + + function To_Tnode_Common is new Ada.Unchecked_Conversion + (Source => Tnode_Subarray, Target => Tnode_Common); + + function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32) + return O_Tnode + is + Res : O_Tnode; + Size : Uns32; + begin + Size := Get_Type_Size (Get_Type_Array_Element (Atype)); + Tnodes.Append (Tnode_Common'(Kind => OT_Subarray, + Mode => Mode_Blk, + Align => Get_Type_Align (Atype), + Pad0 => (others => False), + Size => Size * Length)); + Res := Tnodes.Last; + Tnodes.Append (To_Tnode_Common (Tnode_Subarray'(Base_Type => Atype, + Length => Length))); + return Res; + end New_Constrained_Array_Type; + + function To_Tnode_Common is new Ada.Unchecked_Conversion + (Source => Tnode_Access, Target => Tnode_Common); + + function New_Access_Type (Dtype : O_Tnode) return O_Tnode + is + Res : O_Tnode; + begin + Tnodes.Append (Tnode_Common'(Kind => OT_Access, + Mode => Mode_P32, + Align => Mode_Align (Mode_P32), + Pad0 => (others => False), + Size => 4)); + Res := Tnodes.Last; + Tnodes.Append (To_Tnode_Common (Tnode_Access'(Dtype => Dtype, + Pad => 0))); + return Res; + end New_Access_Type; + + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is + begin + if Get_Type_Access_Type (Atype) /= O_Tnode_Null then + raise Program_Error; + end if; + Tnodes.Table (Atype + 1) := + To_Tnode_Common (Tnode_Access'(Dtype => Dtype, + Pad => 0)); + end Finish_Access_Type; + + + function To_Tnode_Common is new Ada.Unchecked_Conversion + (Source => Tnode_Record, Target => Tnode_Common); + + function Create_Record_Type return O_Tnode + is + Res : O_Tnode; + begin + Tnodes.Append (Tnode_Common'(Kind => OT_Record, + Mode => Mode_Blk, + Align => 0, + Pad0 => (others => False), + Size => 0)); + Res := Tnodes.Last; + Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null, + Nbr_Fields => 0))); + return Res; + end Create_Record_Type; + + procedure Start_Record_Type (Elements : out O_Element_List) + is + begin + Elements := (Res => Create_Record_Type, + First_Field => O_Fnode_Null, + Last_Field => O_Fnode_Null, + Off => 0, + Align => 0, + Nbr => 0); + end Start_Record_Type; + + procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is + begin + Res := Create_Record_Type; + end New_Uncomplete_Record_Type; + + procedure Start_Uncomplete_Record_Type (Res : O_Tnode; + Elements : out O_Element_List) + is + begin + Elements := (Res => Res, + First_Field => O_Fnode_Null, + Last_Field => O_Fnode_Null, + Off => 0, + Align => 0, + Nbr => 0); + end Start_Uncomplete_Record_Type; + + function Get_Mode_Size (Mode : Mode_Type) return Uns32 is + begin + case Mode is + when Mode_B2 + | Mode_U8 + | Mode_I8 => + return 1; + when Mode_I16 + | Mode_U16 => + return 2; + when Mode_I32 + | Mode_U32 + | Mode_P32 + | Mode_F32 => + return 4; + when Mode_I64 + | Mode_U64 + | Mode_P64 + | Mode_F64 => + return 8; + when Mode_X1 + | Mode_Nil + | Mode_Blk => + raise Program_Error; + end case; + end Get_Mode_Size; + + function Do_Align (Off : Uns32; Atype : O_Tnode) return Uns32 + is + Msk : Uns32; + begin + -- Align. + Msk := Get_Type_Align_Byte (Atype) - 1; + return (Off + Msk) and (not Msk); + end Do_Align; + + function Do_Align (Off : Uns32; Mode : Mode_Type) return Uns32 + is + Msk : Uns32; + begin + -- Align. + Msk := Get_Mode_Size (Mode) - 1; + return (Off + Msk) and (not Msk); + end Do_Align; + + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode) + is + begin + Elements.Off := Do_Align (Elements.Off, Etype); + + Fnodes.Append (Field_Type'(Ident => Ident, + Ftype => Etype, + Offset => Elements.Off, + Next => O_Fnode_Null)); + El := Fnodes.Last; + Elements.Off := Elements.Off + Get_Type_Size (Etype); + if Get_Type_Align (Etype) > Elements.Align then + Elements.Align := Get_Type_Align (Etype); + end if; + if Elements.Last_Field /= O_Fnode_Null then + Fnodes.Table (Elements.Last_Field).Next := Fnodes.Last; + else + Elements.First_Field := Fnodes.Last; + end if; + Elements.Last_Field := Fnodes.Last; + Elements.Nbr := Elements.Nbr + 1; + end New_Record_Field; + + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode) + is + begin + Tnodes.Table (Elements.Res).Size := Do_Align (Elements.Off, + Elements.Res); + Tnodes.Table (Elements.Res).Align := Elements.Align; + Tnodes.Table (Elements.Res + 1) := To_Tnode_Common + (Tnode_Record'(Fields => Elements.First_Field, + Nbr_Fields => Elements.Nbr)); + Res := Elements.Res; + end Finish_Record_Type; + + procedure Start_Union_Type (Elements : out O_Element_List) + is + begin + Tnodes.Append (Tnode_Common'(Kind => OT_Union, + Mode => Mode_Blk, + Align => 0, + Pad0 => (others => False), + Size => 0)); + Elements := (Res => Tnodes.Last, + First_Field => O_Fnode_Null, + Last_Field => O_Fnode_Null, + Off => 0, + Align => 0, + Nbr => 0); + Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null, + Nbr_Fields => 0))); + end Start_Union_Type; + + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode) + is + Off : Uns32; + begin + Off := Elements.Off; + Elements.Off := 0; + New_Record_Field (Elements, El, Ident, Etype); + if Off > Elements.Off then + Elements.Off := Off; + end if; + end New_Union_Field; + + procedure Finish_Union_Type + (Elements : in out O_Element_List; Res : out O_Tnode) + is + begin + Finish_Record_Type (Elements, Res); + end Finish_Union_Type; + + function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode + is + Base : O_Tnode; + begin + case Get_Type_Kind (Atype) is + when OT_Ucarray => + Base := Atype; + when OT_Subarray => + Base := Get_Type_Subarray_Base (Atype); + when others => + raise Program_Error; + end case; + return Get_Type_Ucarray_Element (Base); + end Get_Type_Array_Element; + + procedure Disp_Type (Atype : O_Tnode) + is + use Ortho_Code.Debug.Int32_IO; + use Ada.Text_IO; + Kind : OT_Kind; + begin + Put (Int32 (Atype), 3); + Put (" "); + Kind := Get_Type_Kind (Atype); + Put (OT_Kind'Image (Get_Type_Kind (Atype))); + Put (" "); + Put (Mode_Type'Image (Get_Type_Mode (Atype))); + New_Line; + case Kind is + when OT_Boolean => + Put (" false: "); + Put (Int32 (Get_Type_Bool_False (Atype))); + Put (", true: "); + Put (Int32 (Get_Type_Bool_True (Atype))); + New_Line; + when others => + null; + end case; + end Disp_Type; + + procedure Mark (M : out Mark_Type) is + begin + M.Tnode := Tnodes.Last; + M.Fnode := Fnodes.Last; + end Mark; + + procedure Release (M : Mark_Type) is + begin + Tnodes.Set_Last (M.Tnode); + Fnodes.Set_Last (M.Fnode); + end Release; + + procedure Disp_Stats + is + use Ada.Text_IO; + begin + Put_Line ("Number of Tnodes: " & O_Tnode'Image (Tnodes.Last)); + Put_Line ("Number of Fnodes: " & O_Fnode'Image (Fnodes.Last)); + end Disp_Stats; + + procedure Finish is + begin + Tnodes.Free; + Fnodes.Free; + end Finish; +end Ortho_Code.Types; diff --git a/ortho/mcode/ortho_code-types.ads b/ortho/mcode/ortho_code-types.ads new file mode 100644 index 0000000..e64055e --- /dev/null +++ b/ortho/mcode/ortho_code-types.ads @@ -0,0 +1,203 @@ +-- Mcode back-end for ortho - type handling. +-- 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. +package Ortho_Code.Types is + type OT_Kind is (OT_Unsigned, OT_Signed, OT_Boolean, OT_Enum, OT_Float, + OT_Ucarray, OT_Subarray, OT_Access, + OT_Record, OT_Union); + + -- Kind of ATYPE. + function Get_Type_Kind (Atype : O_Tnode) return OT_Kind; + + -- Number of bytes of type ATYPE. + function Get_Type_Size (Atype : O_Tnode) return Uns32; + + -- Same as Get_Type_Size but for modes. + -- Returns 0 in case of error. + function Get_Mode_Size (Mode : Mode_Type) return Uns32; + + -- Alignment for ATYPE, in power of 2. + subtype Small_Natural is Natural range 0 .. 3; + type Mode_Align_Array is array (Mode_Type) of Small_Natural; + function Get_Type_Align (Atype : O_Tnode) return Small_Natural; + + -- Align OFF on ATYPE. + function Do_Align (Off : Uns32; Atype : O_Tnode) return Uns32; + function Do_Align (Off : Uns32; Mode : Mode_Type) return Uns32; + + -- Get the mode for ATYPE. + function Get_Type_Mode (Atype : O_Tnode) return Mode_Type; + + -- Get the type designated by access type ATYPE. + function Get_Type_Access_Type (Atype : O_Tnode) return O_Tnode; + + -- Get the index type of array type ATYPE. + function Get_Type_Ucarray_Index (Atype : O_Tnode) return O_Tnode; + + -- Get the element type of array type ATYPE. + function Get_Type_Ucarray_Element (Atype : O_Tnode) return O_Tnode; + + -- Get the base type of array type ATYPE. + function Get_Type_Subarray_Base (Atype : O_Tnode) return O_Tnode; + + -- Get number of element for array type ATYPE. + function Get_Type_Subarray_Length (Atype : O_Tnode) return Uns32; + + -- Get the first field of record/union ATYPE. + function Get_Type_Record_Fields (Atype : O_Tnode) return O_Fnode; + + -- Get the number of fields of record/union ATYPE. + function Get_Type_Record_Nbr_Fields (Atype : O_Tnode) return Uns32; + + -- Get the first literal of enum type ATYPE. + function Get_Type_Enum_Lits (Atype : O_Tnode) return O_Cnode; + + -- Get the POS th literal of enum type ATYPE. + -- The first is when POS = 0. + function Get_Type_Enum_Lit (Atype : O_Tnode; Pos : Uns32) return O_Cnode; + + -- Get the number of literals of enum type ATYPE. + function Get_Type_Enum_Nbr_Lits (Atype : O_Tnode) return Uns32; + + -- Get the false/true literal of boolean type ATYPE. + function Get_Type_Bool_False (Atype : O_Tnode) return O_Cnode; + function Get_Type_Bool_True (Atype : O_Tnode) return O_Cnode; + + -- Get the offset of FIELD in its record/union. + function Get_Field_Offset (Field : O_Fnode) return Uns32; + + -- Get the type of FIELD. + function Get_Field_Type (Field : O_Fnode) return O_Tnode; + + -- Get the name of FIELD. + function Get_Field_Ident (Field : O_Fnode) return O_Ident; + + -- Get the next field. + function Get_Field_Chain (Field : O_Fnode) return O_Fnode; + + -- Build a scalar type; size may be 8, 16, 32 or 64. + function New_Unsigned_Type (Size : Natural) return O_Tnode; + function New_Signed_Type (Size : Natural) return O_Tnode; + + -- Build a float type. + function New_Float_Type return O_Tnode; + + -- Build a boolean type. + procedure New_Boolean_Type (Res : out O_Tnode; + False_Id : O_Ident; + False_E : out O_Cnode; + True_Id : O_Ident; + True_E : out O_Cnode); + + -- Create an enumeration + type O_Enum_List is limited private; + + -- Elements are declared in order, the first is ordered from 0. + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural); + procedure New_Enum_Literal (List : in out O_Enum_List; + Ident : O_Ident; Res : out O_Cnode); + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode); + + + -- Build an access type. + -- DTYPE may be O_tnode_null in order to build an incomplete access type. + -- It is completed with finish_access_type. + function New_Access_Type (Dtype : O_Tnode) return O_Tnode; + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode); + + + -- Build an array type. + -- The array is not constrained and unidimensional. + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode; + + -- Build a constrained array type. + function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32) + return O_Tnode; + + + type O_Element_List is limited private; + + -- Build a record type. + procedure Start_Record_Type (Elements : out O_Element_List); + -- Add a field in the record; not constrained array are prohibited, since + -- its size is unlimited. + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; Etype : O_Tnode); + -- Finish the record type. + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode); + + -- Build an uncomplete record type: + -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. + -- This type can be declared or used to define access types on it. + -- Then, complete (if necessary) the record type, by calling + -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. + procedure New_Uncomplete_Record_Type (Res : out O_Tnode); + procedure Start_Uncomplete_Record_Type (Res : O_Tnode; + Elements : out O_Element_List); + + -- Build an union type. + procedure Start_Union_Type (Elements : out O_Element_List); + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode); + procedure Finish_Union_Type + (Elements : in out O_Element_List; Res : out O_Tnode); + + -- Non-primitives. + + -- Type of an element of a ucarray or constrained array. + function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode; + + procedure Disp_Stats; + + -- Free all the memory used. + procedure Finish; + + type Mark_Type is limited private; + procedure Mark (M : out Mark_Type); + procedure Release (M : Mark_Type); + +private + type O_Enum_List is record + Res : O_Tnode; + First : O_Cnode; + Last : O_Cnode; + Nbr : Uns32; + end record; + + type O_Element_List is record + Res : O_Tnode; + Nbr : Uns32; + Off : Uns32; + Align : Small_Natural; + First_Field : O_Fnode; + Last_Field : O_Fnode; + end record; + + type Mark_Type is record + Tnode : O_Tnode; + Fnode : O_Fnode; + end record; + +end Ortho_Code.Types; + diff --git a/ortho/mcode/ortho_code-x86-abi.adb b/ortho/mcode/ortho_code-x86-abi.adb new file mode 100644 index 0000000..1515c2e --- /dev/null +++ b/ortho/mcode/ortho_code-x86-abi.adb @@ -0,0 +1,731 @@ +-- X86 ABI definitions. +-- 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 Ortho_Code.Decls; use Ortho_Code.Decls; +with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Exprs; use Ortho_Code.Exprs; +with Ortho_Code.Consts; +with Ortho_Code.Debug; +with Ortho_Code.Disps; +with Ortho_Code.Flags; +with Ortho_Code.Dwarf; +with Ortho_Code.X86; use Ortho_Code.X86; +with Ortho_Code.X86.Insns; +with Ortho_Code.X86.Emits; +with Binary_File; +with Binary_File.Memory; +with Ada.Text_IO; + +package body Ortho_Code.X86.Abi is + procedure Start_Subprogram (Subprg : O_Dnode; Abi : out O_Abi_Subprg) + is + pragma Unreferenced (Subprg); + begin + Abi.Offset := 8; + end Start_Subprogram; + + procedure New_Interface (Inter : O_Dnode; Abi : in out O_Abi_Subprg) + is + Itype : O_Tnode; + Size : Uns32; + begin + Itype := Get_Decl_Type (Inter); + Size := Get_Type_Size (Itype); + Size := (Size + 3) and not 3; + Set_Local_Offset (Inter, Abi.Offset); + Abi.Offset := Abi.Offset + Int32 (Size); + end New_Interface; + + procedure Finish_Subprogram (Subprg : O_Dnode; Abi : in out O_Abi_Subprg) + is + use Binary_File; + function To_Int32 is new Ada.Unchecked_Conversion + (Source => Symbol, Target => Int32); + begin + Set_Decl_Info (Subprg, + To_Int32 (Create_Symbol (Get_Decl_Ident (Subprg)))); + Set_Subprg_Stack (Subprg, Abi.Offset - 8); + end Finish_Subprogram; + + procedure Link_Stmt (Stmt : O_Enode) is + begin + Set_Stmt_Link (Last_Link, Stmt); + Last_Link := Stmt; + end Link_Stmt; + + procedure Disp_Subprg (Subprg : O_Dnode); + + + Exprs_Mark : Exprs.Mark_Type; + Decls_Mark : Decls.Mark_Type; + Consts_Mark : Consts.Mark_Type; + Types_Mark : Types.Mark_Type; + Dwarf_Mark : Dwarf.Mark_Type; + + procedure Start_Body (Subprg : O_Dnode) + is + pragma Unreferenced (Subprg); + begin + if not Debug.Flag_Debug_Keep then + Mark (Exprs_Mark); + Mark (Decls_Mark); + Consts.Mark (Consts_Mark); + Mark (Types_Mark); + Dwarf.Mark (Dwarf_Mark); + end if; + end Start_Body; + + procedure Finish_Body (Subprg : Subprogram_Data_Acc) + is + use Ortho_Code.Flags; + + Child : Subprogram_Data_Acc; + begin + if Debug.Flag_Debug_Hli then + Disps.Disp_Subprg (Subprg); + return; + end if; + + Insns.Gen_Subprg_Insns (Subprg); + + if Ortho_Code.Debug.Flag_Debug_Body2 then + Disp_Subprg_Body (1, Subprg.E_Entry); + end if; + + if Ortho_Code.Debug.Flag_Debug_Code then + Disp_Subprg (Subprg.D_Body); + end if; + + Emits.Emit_Subprg (Subprg); + + -- Recurse on nested subprograms. + Child := Subprg.First_Child; + while Child /= null loop + Finish_Body (Child); + Child := Child.Brother; + end loop; + + if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel then + if Flag_Debug = Debug_Dwarf then + Dwarf.Emit_Subprg (Subprg.D_Body); + end if; + + if not Debug.Flag_Debug_Keep then + Release (Exprs_Mark); + Release (Decls_Mark); + Consts.Release (Consts_Mark); + Release (Types_Mark); + Dwarf.Release (Dwarf_Mark); + end if; + end if; + end Finish_Body; + + procedure Expand_Const_Decl (Decl : O_Dnode) is + begin + Emits.Emit_Const_Decl (Decl); + end Expand_Const_Decl; + + procedure Expand_Var_Decl (Decl : O_Dnode) is + begin + Emits.Emit_Var_Decl (Decl); + end Expand_Var_Decl; + + procedure Expand_Const_Value (Decl : O_Dnode; Val : O_Cnode) is + begin + Emits.Emit_Const_Value (Decl, Val); + end Expand_Const_Value; + + procedure Disp_Label (Label : O_Enode) + is + use Ada.Text_IO; + use Ortho_Code.Debug.Int32_IO; + begin + Put ("L"); + Put (Int32 (Label), 0); + end Disp_Label; + + procedure Disp_Reg (Reg : O_Enode) + is + use Ada.Text_IO; + use Ortho_Code.Debug.Int32_IO; + begin + Put ("reg_"); + Put (Int32 (Reg), 0); + Put ("{"); + Put (Image_Reg (Get_Expr_Reg (Reg))); + Put ("}"); + end Disp_Reg; + + procedure Disp_Local (Stmt : O_Enode) + is + use Ada.Text_IO; + use Ortho_Code.Debug.Int32_IO; + Obj : O_Dnode := Get_Addr_Object (Stmt); + Frame : O_Enode := Get_Addrl_Frame (Stmt); + begin + if Frame = O_Enode_Null then + Put ("fp"); + else + Disp_Reg (Frame); + end if; + Put (","); + Put (Get_Local_Offset (Obj), 0); + Put (" {"); + Disp_Decl_Name (Obj); + Put ("}"); + end Disp_Local; + + procedure Disp_Uns32 (Val : Uns32) + is + use Ada.Text_IO; + U2c : constant array (Uns32 range 0 .. 15) of Character + := "0123456789abcdef"; + V : Uns32 := Val; + begin + for I in 0 .. 7 loop + Put (U2c (Shift_Right (V, 28))); + V := Shift_Left (V, 4); + end loop; + end Disp_Uns32; + + procedure Disp_Const (Stmt : O_Enode) + is + use Ada.Text_IO; + begin + Put ("["); + case Get_Expr_Mode (Stmt) is + when Mode_U64 + | Mode_I64 + | Mode_F64 => + Disp_Uns32 (Get_Expr_High (Stmt)); + Put (","); + when others => + null; + end case; + Disp_Uns32 (Get_Expr_Low (Stmt)); + Put ("]"); + end Disp_Const; + + procedure Disp_Irm_Code (Stmt : O_Enode) + is + use Ortho_Code.Debug.Int32_IO; + use Ada.Text_IO; + Reg : O_Reg; + Kind : OE_Kind; + begin + Reg := Get_Expr_Reg (Stmt); + Kind := Get_Expr_Kind (Stmt); + case Reg is + when R_Mem => + case Kind is + when OE_Indir => + Put ('('); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + Put (')'); +-- when OE_Lit => +-- Put ("(&n)"); + when others => + raise Program_Error; + end case; + when R_Imm => + case Kind is + when OE_Const => + Disp_Const (Stmt); + when OE_Addrg => + Put ("&"); + Disp_Decl_Name (Get_Addr_Object (Stmt)); + when OE_Add => + Disp_Irm_Code (Get_Expr_Left (Stmt)); + Put ("+"); + Disp_Irm_Code (Get_Expr_Right (Stmt)); + when others => + raise Program_Error; + end case; + when Regs_R32 + | R_Any32 + | R_Any8 + | Regs_R64 + | R_Any64 + | Regs_Cc + | Regs_Fp => + Disp_Reg (Stmt); + when R_Spill => + Disp_Reg (Stmt); + --Disp_Irm_Code (Get_Stmt_Link (Stmt)); + when R_B_Off + | R_I_Off + | R_B_I + | R_Sib => + case Kind is + when OE_Addrl => + Disp_Local (Stmt); + when OE_Add => + Disp_Irm_Code (Get_Expr_Left (Stmt)); + Put (" + "); + Disp_Irm_Code (Get_Expr_Right (Stmt)); + when others => + raise Program_Error; + end case; + when R_I => + Disp_Irm_Code (Get_Expr_Left (Stmt)); + Put (" * "); + case Get_Expr_Low (Get_Expr_Right (Stmt)) is + when 0 => + Put ('1'); + when 1 => + Put ('2'); + when 2 => + Put ('4'); + when 3 => + Put ('8'); + when others => + Put ('?'); + end case; + when others => + Ada.Text_IO.Put_Line + ("abi.disp_irm_code: unhandled reg=" & Image_Reg (Reg) + & ", stmt=" & O_Enode'Image (Stmt)); + raise Program_Error; + end case; + end Disp_Irm_Code; + + procedure Disp_Decls (Block : O_Dnode) + is + Decl : O_Dnode; + Last : O_Dnode; + begin + Last := Get_Block_Last (Block); + Disp_Decl (2, Block); + Decl := Block + 1; + while Decl <= Last loop + case Get_Decl_Kind (Decl) is + when OD_Local => + Disp_Decl (2, Decl); + when OD_Block => + -- Skip internal blocks. + Decl := Get_Block_Last (Decl); + when others => + Disp_Decl (2, Decl); + null; + end case; + Decl := Decl + 1; + end loop; + end Disp_Decls; + + procedure Disp_Stmt (Stmt : O_Enode) + is + use Ada.Text_IO; + use Debug.Int32_IO; + Kind : OE_Kind; + Mode : Mode_Type; + + procedure Disp_Op_Name (Name : String) is + begin + Put (Name); + Put (":"); + Debug.Disp_Mode (Mode); + Put (" "); + end Disp_Op_Name; + + procedure Disp_Reg_Op_Name (Name : String) is + begin + Put (" "); + Disp_Reg (Stmt); + Put (" = "); + Disp_Op_Name (Name); + end Disp_Reg_Op_Name; + + begin + Kind := Get_Expr_Kind (Stmt); + Mode := Get_Expr_Mode (Stmt); + + case Kind is + when OE_Beg => + Put (" # block start"); + if Get_Block_Has_Alloca (Stmt) then + Put (" [alloca]"); + end if; + New_Line; + Disp_Decls (Get_Block_Decls (Stmt)); + when OE_End => + Put_Line (" # block end"); + when OE_Indir => + Disp_Reg_Op_Name ("indir"); + Put ("("); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + Put_Line (")"); + when OE_Alloca => + Disp_Reg_Op_Name ("alloca"); + Put ("("); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + Put_Line (")"); + when OE_Kind_Cmp + | OE_Kind_Dyadic => + Disp_Reg_Op_Name ("op"); + Put ("{"); + Put (OE_Kind'Image (Kind)); + Put ("} "); + Disp_Irm_Code (Get_Expr_Left (Stmt)); + Put (", "); + Disp_Irm_Code (Get_Expr_Right (Stmt)); + New_Line; + when OE_Abs_Ov + | OE_Neg_Ov + | OE_Not => + Disp_Reg_Op_Name ("op"); + Put ("{"); + Put (OE_Kind'Image (Kind)); + Put ("} "); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Const => + Disp_Reg_Op_Name ("const"); + Disp_Const (Stmt); + New_Line; + when OE_Jump_F => + Put (" jump_f "); + Disp_Reg (Get_Expr_Operand (Stmt)); + Put (" "); + Disp_Label (Get_Jump_Label (Stmt)); + New_Line; + when OE_Jump_T => + Put (" jump_t "); + Disp_Reg (Get_Expr_Operand (Stmt)); + Put (" "); + Disp_Label (Get_Jump_Label (Stmt)); + New_Line; + when OE_Jump => + Put (" jump "); + Disp_Label (Get_Jump_Label (Stmt)); + New_Line; + when OE_Label => + Disp_Label (Stmt); + Put_Line (":"); + when OE_Asgn => + Put (" assign:"); + Debug.Disp_Mode (Mode); + Put (" ("); + Disp_Irm_Code (Get_Assign_Target (Stmt)); + Put (") <- "); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Set_Stack => + Put (" set_stack"); + Put (" <- "); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Spill => + Disp_Reg_Op_Name ("spill"); + Disp_Reg (Get_Expr_Operand (Stmt)); + Put (", offset="); + Put (Int32'Image (Get_Spill_Info (Stmt))); + New_Line; + when OE_Reload => + Disp_Reg_Op_Name ("reload"); + Disp_Reg (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Arg => + Put (" push "); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Call => + if Get_Expr_Mode (Stmt) /= Mode_Nil then + Disp_Reg_Op_Name ("call"); + else + Put (" "); + Disp_Op_Name ("call"); + Put (" "); + end if; + Disp_Decl_Name (Get_Call_Subprg (Stmt)); + New_Line; + when OE_Intrinsic => + Disp_Reg_Op_Name ("intrinsic"); + --Disp_Decl_Name (Get_Call_Subprg (Stmt)); + New_Line; + when OE_Conv => + Disp_Reg_Op_Name ("conv"); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Move => + Disp_Reg_Op_Name ("move"); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Ret => + Put (" ret"); + if Get_Expr_Mode (Stmt) /= Mode_Nil then + Put (" "); + Disp_Reg (Get_Expr_Operand (Stmt)); + end if; + New_Line; + when OE_Case => + Disp_Reg_Op_Name ("case"); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Case_Expr => + Disp_Reg_Op_Name ("case_expr"); + Disp_Irm_Code (Get_Expr_Operand (Stmt)); + New_Line; + when OE_Leave => + Put_Line ("leave"); + when OE_Entry => + Put_Line ("entry"); + when OE_Line => + Put (" # line #"); + Put (Get_Expr_Line_Number (Stmt), 0); + New_Line; + when OE_Addrl => + Disp_Reg_Op_Name ("lea{addrl}"); + Put ("("); + Disp_Local (Stmt); + Put (")"); + New_Line; + when OE_Addrg => + Disp_Reg_Op_Name ("lea{addrg}"); + Put ("&"); + Disp_Decl_Name (Get_Addr_Object (Stmt)); + New_Line; + when OE_Add => + Disp_Reg_Op_Name ("lea{add}"); + Put ("("); + Disp_Irm_Code (Get_Expr_Left (Stmt)); + Put (" + "); + Disp_Irm_Code (Get_Expr_Right (Stmt)); + Put (")"); + New_Line; + when OE_Mul => + Disp_Reg_Op_Name ("mul"); + Disp_Irm_Code (Get_Expr_Left (Stmt)); + Put (", "); + Disp_Irm_Code (Get_Expr_Right (Stmt)); + New_Line; + when OE_Shl => + Disp_Reg_Op_Name ("shl"); + Disp_Irm_Code (Get_Expr_Left (Stmt)); + Put (", "); + Disp_Irm_Code (Get_Expr_Right (Stmt)); + New_Line; + when OE_Reg => + Disp_Reg_Op_Name ("reg"); + New_Line; + when others => + Ada.Text_IO.Put_Line + ("abi.disp_stmt: unhandled enode " & OE_Kind'Image (Kind)); + raise Program_Error; + end case; + end Disp_Stmt; + + procedure Disp_Subprg_Decl (Decl : O_Dnode) + is + use Ada.Text_IO; + Arg : O_Dnode; + begin + Put ("subprogram "); + Disp_Decl_Name (Decl); + Put_Line (":"); + Arg := Decl + 1; + while Get_Decl_Kind (Arg) = OD_Interface loop + Disp_Decl (2, Arg); + Arg := Arg + 1; + end loop; + end Disp_Subprg_Decl; + + procedure Disp_Subprg (Subprg : O_Dnode) + is + use Ada.Text_IO; + + Last : O_Enode; + Stmt : O_Enode; + begin + Disp_Subprg_Decl (Get_Body_Decl (Subprg)); + + Stmt := Get_Body_Stmt (Subprg); + Last := Get_Entry_Leave (Stmt); + loop + exit when Stmt = O_Enode_Null; + Disp_Stmt (Stmt); + exit when Get_Expr_Kind (Stmt) = OE_Leave; + Stmt := Get_Stmt_Link (Stmt); + end loop; + end Disp_Subprg; + + procedure New_Debug_Filename_Decl (Filename : String) + is + use Ortho_Code.Flags; + begin + if Flag_Debug = Debug_Dwarf then + Dwarf.Set_Filename ("", Filename); + end if; + end New_Debug_Filename_Decl; + + procedure Init + is + use Ortho_Code.Debug; + begin + if Flag_Debug_Hli then + Disps.Init; + else + Emits.Init; + end if; + end Init; + + procedure Finish + is + use Ortho_Code.Debug; + begin + if Flag_Debug_Hli then + Disps.Finish; + else + Emits.Finish; + end if; + end Finish; + +-- function Image_Insn (Insn : O_Insn) return String is +-- begin +-- case Insn is +-- when Insn_Nil => +-- return "nil"; +-- when Insn_Imm => +-- return "imm"; +-- when Insn_Base_Off => +-- return "B+O"; +-- when Insn_Loadm => +-- return "ldm"; +-- when Insn_Loadi => +-- return "ldi"; +-- when Insn_Mem => +-- return "mem"; +-- when Insn_Cmp => +-- return "cmp"; +-- when Insn_Op => +-- return "op "; +-- when Insn_Rop => +-- return "rop"; +-- when Insn_Call => +-- return "cal"; +-- when others => +-- return "???"; +-- end case; +-- end Image_Insn; + + function Image_Reg (Reg : O_Reg) return String is + begin + case Reg is + when R_Nil => + return "nil "; + when R_None => + return " -- "; + when R_Spill => + return "spil"; + when R_Mem => + return "mem "; + when R_Imm => + return "imm "; + when R_Irm => + return "irm "; + when R_Rm => + return "rm "; + when R_Sib => + return "sib "; + when R_B_Off => + return "b+o "; + when R_B_I => + return "b+i "; + when R_I => + return "s*i "; + when R_Ir => + return " ir "; + when R_I_Off => + return "i+o "; + when R_Any32 => + return "r32 "; + when R_Any_Cc => + return "cc "; + when R_Any8 => + return "r8 "; + when R_Any64 => + return "r64 "; + + when R_St0 => + return "st0 "; + when R_Ax => + return "ax "; + when R_Dx => + return "dx "; + when R_Cx => + return "cx "; + when R_Bx => + return "bx "; + when R_Si => + return "si "; + when R_Di => + return "di "; + when R_Sp => + return "sp "; + when R_Bp => + return "bp "; + when R_Edx_Eax => + return "dxax"; + when R_Ebx_Ecx => + return "bxcx"; + when R_Esi_Edi => + return "sidi"; + when R_Eq => + return "eq? "; + when R_Ne => + return "ne? "; + when R_Uge => + return "uge?"; + when R_Sge => + return "sge?"; + when R_Ugt => + return "ugt?"; + when R_Sgt => + return "sgt?"; + when R_Ule => + return "ule?"; + when R_Sle => + return "sle?"; + when R_Ult => + return "ult?"; + when R_Slt => + return "slt?"; + when others => + return "????"; + end case; + end Image_Reg; + + -- From GCC. + -- FIXME: these don't handle overflow! + function Divdi3 (A, B : Long_Integer) return Long_Integer; + pragma Import (C, Divdi3, "__divdi3"); + + function Muldi3 (A, B : Long_Integer) return Long_Integer; + pragma Import (C, Muldi3, "__muldi3"); + + procedure Link_Intrinsics + is + begin + Binary_File.Memory.Set_Symbol_Address + (Ortho_Code.X86.Emits.Intrinsics_Symbol + (Ortho_Code.X86.Intrinsic_Mul_Ov_I64), + Muldi3'Address); + Binary_File.Memory.Set_Symbol_Address + (Ortho_Code.X86.Emits.Intrinsics_Symbol + (Ortho_Code.X86.Intrinsic_Div_Ov_I64), + Divdi3'Address); + end Link_Intrinsics; +end Ortho_Code.X86.Abi; diff --git a/ortho/mcode/ortho_code-x86-abi.ads b/ortho/mcode/ortho_code-x86-abi.ads new file mode 100644 index 0000000..613e37b --- /dev/null +++ b/ortho/mcode/ortho_code-x86-abi.ads @@ -0,0 +1,72 @@ +-- X86 ABI definitions. +-- 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 Ortho_Code.Exprs; use Ortho_Code.Exprs; +with Ortho_Code.Types; use Ortho_Code.Types; + +package Ortho_Code.X86.Abi is + type O_Abi_Subprg is private; + + procedure Init; + procedure Finish; + + Mode_Align : constant Mode_Align_Array := + (Mode_U8 | Mode_I8 => 0, + Mode_U16 | Mode_I16 => 1, + Mode_U32 | Mode_I32 | Mode_F32 | Mode_P32 => 2, + Mode_U64 | Mode_I64 => 2, + Mode_F64 => 2, + Mode_Blk | Mode_X1 | Mode_Nil | Mode_P64 => 0, + Mode_B2 => 0); + + Mode_Ptr : constant Mode_Type := Mode_P32; + + -- Procedures to layout a subprogram declaration. + procedure Start_Subprogram (Subprg : O_Dnode; Abi : out O_Abi_Subprg); + procedure New_Interface (Inter : O_Dnode; Abi : in out O_Abi_Subprg); + procedure Finish_Subprogram (Subprg : O_Dnode; Abi : in out O_Abi_Subprg); + + -- Only called for top-level subprograms. + procedure Start_Body (Subprg : O_Dnode); + -- Finish compilation of a body. + procedure Finish_Body (Subprg : Subprogram_Data_Acc); + + procedure Expand_Const_Decl (Decl : O_Dnode); + procedure Expand_Var_Decl (Decl : O_Dnode); + procedure Expand_Const_Value (Decl : O_Dnode; Val : O_Cnode); + + procedure New_Debug_Filename_Decl (Filename : String); + + Last_Link : O_Enode; + procedure Link_Stmt (Stmt : O_Enode); + + -- Disp SUBPRG (subprg declaration) as a declaration (name and interfaces). + procedure Disp_Subprg_Decl (Decl : O_Dnode); + + procedure Disp_Stmt (Stmt : O_Enode); + + --function Image_Insn (Insn : O_Insn) return String; + function Image_Reg (Reg : O_Reg) return String; + + -- Link in memory intrinsics symbols. + procedure Link_Intrinsics; +private + type O_Abi_Subprg is record + -- For x86: offset of the next argument. + Offset : Int32 := 0; + end record; +end Ortho_Code.X86.Abi; diff --git a/ortho/mcode/ortho_code-x86-emits.adb b/ortho/mcode/ortho_code-x86-emits.adb new file mode 100644 index 0000000..a857291 --- /dev/null +++ b/ortho/mcode/ortho_code-x86-emits.adb @@ -0,0 +1,2252 @@ +-- Mcode back-end for ortho - Binary X86 instructions 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 Ortho_Code.Abi; +with Ortho_Code.Decls; +with Ortho_Code.Types; +with Ortho_Code.Consts; +with Ortho_Code.Debug; +with Ortho_Code.X86.Insns; +with Ortho_Code.Flags; +with Ortho_Code.Dwarf; +with Ortho_Code.Binary; use Ortho_Code.Binary; +with Ortho_Ident; +with Ada.Text_IO; +with Interfaces; use Interfaces; +with Binary_File; use Binary_File; + +package body Ortho_Code.X86.Emits is + type Insn_Size is (Sz_8, Sz_16, Sz_32l, Sz_32h); + + type Fp_Size is (Fp_32, Fp_64); + + Sect_Text : Binary_File.Section_Acc; + Sect_Rodata : Binary_File.Section_Acc; + Sect_Bss : Binary_File.Section_Acc; + + Reg_Helper : O_Reg; + + Subprg_Pc : Pc_Type; + + procedure Error_Emit (Msg : String; Insn : O_Enode) + is + use Ada.Text_IO; + begin + Put ("error_emit: "); + Put (Msg); + Put (", insn="); + Put (O_Enode'Image (Insn)); + Put (" ("); + Put (OE_Kind'Image (Get_Expr_Kind (Insn))); + Put (")"); + New_Line; + raise Program_Error; + end Error_Emit; + + + procedure Gen_Insn_Sz (B : Byte; Sz : Insn_Size) is + begin + case Sz is + when Sz_8 => + Gen_B8 (B); + when Sz_16 => + Gen_B8 (16#66#); + Gen_B8 (B + 1); + when Sz_32l + | Sz_32h => + Gen_B8 (B + 1); + end case; + end Gen_Insn_Sz; + + procedure Gen_Insn_Sz_S8 (B : Byte; Sz : Insn_Size) is + begin + case Sz is + when Sz_8 => + Gen_B8 (B); + when Sz_16 => + Gen_B8 (16#66#); + Gen_B8 (B + 3); + when Sz_32l + | Sz_32h => + Gen_B8 (B + 3); + end case; + end Gen_Insn_Sz_S8; + + function Get_Const_Val (C : O_Enode; Sz : Insn_Size) return Uns32 is + begin + case Sz is + when Sz_8 + | Sz_16 + | Sz_32l => + return Get_Expr_Low (C); + when Sz_32h => + return Get_Expr_High (C); + end case; + end Get_Const_Val; + + function Is_Imm8 (N : O_Enode; Sz : Insn_Size) return Boolean is + begin + if Get_Expr_Kind (N) /= OE_Const then + return False; + end if; + return Get_Const_Val (N, Sz) <= 127; + end Is_Imm8; + + procedure Gen_Imm8 (N : O_Enode; Sz : Insn_Size) is + begin + Gen_B8 (Byte (Get_Const_Val (N, Sz))); + end Gen_Imm8; + +-- procedure Gen_Imm32 (N : O_Enode; Sz : Insn_Size) +-- is +-- use Interfaces; +-- begin +-- case Get_Expr_Kind (N) is +-- when OE_Const => +-- Gen_Le32 (Unsigned_32 (Get_Const_Val (N, Sz))); +-- when OE_Addrg => +-- Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (N)), 0); +-- when others => +-- raise Program_Error; +-- end case; +-- end Gen_Imm32; + + procedure Gen_Imm (N : O_Enode; Sz : Insn_Size) + is + use Interfaces; + begin + case Get_Expr_Kind (N) is + when OE_Const => + case Sz is + when Sz_8 => + Gen_B8 (Byte (Get_Expr_Low (N) and 16#FF#)); + when Sz_16 => + Gen_Le16 (Unsigned_32 (Get_Expr_Low (N) and 16#FF_FF#)); + when Sz_32l => + Gen_Le32 (Unsigned_32 (Get_Expr_Low (N))); + when Sz_32h => + Gen_Le32 (Unsigned_32 (Get_Expr_High (N))); + end case; + when OE_Addrg => + if Sz /= Sz_32l then + raise Program_Error; + end if; + Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (N)), 0); + when OE_Add => + declare + L, R : O_Enode; + S, C : O_Enode; + begin + L := Get_Expr_Left (N); + R := Get_Expr_Right (N); + if Sz /= Sz_32l then + raise Program_Error; + end if; + if Get_Expr_Kind (L) = OE_Addrg + and then Get_Expr_Kind (R) = OE_Const + then + S := L; + C := R; + elsif Get_Expr_Kind (R) = OE_Addrg + and then Get_Expr_Kind (L) = OE_Const + then + S := R; + C := L; + else + raise Program_Error; + end if; + if Get_Expr_Mode (C) /= Mode_U32 then + raise Program_Error; + end if; + Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (S)), + Integer_32 (To_Int32 (Get_Expr_Low (C)))); + end; + when others => + raise Program_Error; + end case; + end Gen_Imm; + + Rm_Base : O_Reg; + Rm_Index : O_Reg; + Rm_Offset : Int32; + Rm_Sym : Symbol; + Rm_Scale : Byte; + + procedure Fill_Sib (N : O_Enode) + is + use Ortho_Code.Decls; + Reg : O_Reg; + begin + Reg := Get_Expr_Reg (N); + if Reg in Regs_R32 then + if Rm_Base = R_Nil then + Rm_Base := Reg; + elsif Rm_Index = R_Nil then + Rm_Index := Reg; + else + raise Program_Error; + end if; + return; + end if; + case Get_Expr_Kind (N) is + when OE_Indir => + Fill_Sib (Get_Expr_Operand (N)); + when OE_Addrl => + declare + Frame : O_Enode; + begin + Frame := Get_Addrl_Frame (N); + if Frame = O_Enode_Null then + Rm_Base := R_Bp; + else + Rm_Base := Get_Expr_Reg (Frame); + end if; + end; + Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Object (N)); + when OE_Addrg => + if Rm_Sym /= Null_Symbol then + raise Program_Error; + end if; + Rm_Sym := Get_Decl_Symbol (Get_Addr_Object (N)); + when OE_Add => + Fill_Sib (Get_Expr_Left (N)); + Fill_Sib (Get_Expr_Right (N)); + when OE_Const => + Rm_Offset := Rm_Offset + To_Int32 (Get_Expr_Low (N)); + when OE_Shl => + if Rm_Index /= R_Nil then + raise Program_Error; + end if; + Rm_Index := Get_Expr_Reg (Get_Expr_Left (N)); + Rm_Scale := Byte (Get_Expr_Low (Get_Expr_Right (N))); + when others => + Error_Emit ("fill_sib", N); + end case; + end Fill_Sib; + + function To_Reg32 (R : O_Reg) return Byte is + begin + return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); + end To_Reg32; + pragma Inline (To_Reg32); + + function To_Reg32 (R : O_Reg; Sz : Insn_Size) return Byte is + begin + case Sz is + when Sz_8 => + if R in Regs_R8 then + return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); + else + raise Program_Error; + end if; + when Sz_16 => + if R in Regs_R32 then + return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); + else + raise Program_Error; + end if; + when Sz_32l => + case R is + when Regs_R32 => + return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); + when R_Edx_Eax => + return 2#000#; + when R_Ebx_Ecx => + return 2#001#; + when R_Esi_Edi => + return 2#111#; + when others => + raise Program_Error; + end case; + when Sz_32h => + case R is + when R_Edx_Eax => + return 2#010#; + when R_Ebx_Ecx => + return 2#011#; + when R_Esi_Edi => + return 2#110#; + when others => + raise Program_Error; + end case; + end case; + end To_Reg32; + + function To_Cond (R : O_Reg) return Byte is + begin + return O_Reg'Pos (R) - O_Reg'Pos (R_Ov); + end To_Cond; + pragma Inline (To_Cond); + + procedure Gen_Sib is + begin + if Rm_Base = R_Nil then + Gen_B8 (Rm_Scale * 2#1_000_000# + + To_Reg32 (Rm_Index) * 2#1_000# + + 2#101#); + else + Gen_B8 (Rm_Scale * 2#1_000_000# + + To_Reg32 (Rm_Index) * 2#1_000# + + To_Reg32 (Rm_Base)); + end if; + end Gen_Sib; + + -- Generate an R/M (+ SIB) byte. + -- R is added to the R/M byte. + procedure Gen_Rm_Mem (R : Byte; N : O_Enode; Sz : Insn_Size) + is + Reg : O_Reg; + begin + Reg := Get_Expr_Reg (N); + Rm_Base := R_Nil; + Rm_Index := R_Nil; + if Sz = Sz_32h then + Rm_Offset := 4; + else + Rm_Offset := 0; + end if; + Rm_Scale := 0; + Rm_Sym := Null_Symbol; + case Reg is + when R_Mem + | R_Imm + | R_Eq + | R_B_Off + | R_B_I + | R_I_Off + | R_Sib => + Fill_Sib (N); + when Regs_R32 => + Rm_Base := Reg; + when R_Spill => + Rm_Base := R_Bp; + Rm_Offset := Rm_Offset + Get_Spill_Info (N); + when others => + Error_Emit ("gen_rm_mem: unhandled reg", N); + end case; + if Rm_Index /= R_Nil then + -- SIB. + if Rm_Base = R_Nil then + Gen_B8 (2#00_000_100# + R); + Rm_Base := R_Bp; + Gen_Sib; + Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); + elsif Rm_Sym = Null_Symbol and Rm_Offset = 0 and Rm_Base /= R_Bp then + Gen_B8 (2#00_000_100# + R); + Gen_Sib; + elsif Rm_Sym = Null_Symbol and Rm_Offset <= 127 and Rm_Offset >= -128 + then + Gen_B8 (2#01_000_100# + R); + Gen_Sib; + Gen_B8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#)); + else + Gen_B8 (2#10_000_100# + R); + Gen_Sib; + Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); + end if; + return; + end if; + case Rm_Base is + when R_Sp => + raise Program_Error; + when R_Nil => + Gen_B8 (2#00_000_101# + R); + Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); + when R_Ax + | R_Bx + | R_Cx + | R_Dx + | R_Bp + | R_Si + | R_Di => + if Rm_Offset = 0 and Rm_Sym = Null_Symbol and Rm_Base /= R_Bp then + Gen_B8 (2#00_000_000# + R + To_Reg32 (Rm_Base)); + elsif Rm_Sym = Null_Symbol + and Rm_Offset <= 127 and Rm_Offset >= -128 + then + Gen_B8 (2#01_000_000# + R + To_Reg32 (Rm_Base)); + Gen_B8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#)); + else + Gen_B8 (2#10_000_000# + R + To_Reg32 (Rm_Base)); + Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); + end if; + when others => + raise Program_Error; + end case; + end Gen_Rm_Mem; + + procedure Gen_Rm (R : Byte; N : O_Enode; Sz : Insn_Size) + is + Reg : O_Reg; + begin + Reg := Get_Expr_Reg (N); + if Reg in Regs_R32 or Reg in Regs_R64 then + Gen_B8 (2#11_000_000# + R + To_Reg32 (Reg, Sz)); + return; + else + Gen_Rm_Mem (R, N, Sz); + end if; + end Gen_Rm; + + procedure Emit_Op (Op : Byte; Stmt : O_Enode; Sz : Insn_Size) + is + L, R : O_Enode; + Lr, Rr : O_Reg; + begin + L := Get_Expr_Left (Stmt); + R := Get_Expr_Right (Stmt); + Lr := Get_Expr_Reg (L); + Rr := Get_Expr_Reg (R); + Start_Insn; + case Rr is + when R_Imm => + if Is_Imm8 (R, Sz) then + Gen_Insn_Sz_S8 (16#80#, Sz); + Gen_Rm (Op, L, Sz); + Gen_Imm8 (R, Sz); + elsif Lr = R_Ax then + Gen_Insn_Sz (2#000_000_100# + Op, Sz); + Gen_Imm (R, Sz); + else + Gen_Insn_Sz (16#80#, Sz); + Gen_Rm (Op, L, Sz); + Gen_Imm (R, Sz); + end if; + when R_Mem + | R_Spill + | Regs_R32 + | Regs_R64 => + Gen_Insn_Sz (2#00_000_010# + Op, Sz); + Gen_Rm (To_Reg32 (Lr, Sz) * 8, R, Sz); + when others => + Error_Emit ("emit_op", Stmt); + end case; + End_Insn; + end Emit_Op; + + procedure Gen_Into is + begin + Start_Insn; + Gen_B8 (2#1100_1110#); + End_Insn; + end Gen_Into; + + procedure Gen_Cdq is + begin + Start_Insn; + Gen_B8 (2#1001_1001#); + End_Insn; + end Gen_Cdq; + + procedure Gen_Mono_Op (Op : Byte; Val : O_Enode; Sz : Insn_Size) is + begin + Start_Insn; + Gen_Insn_Sz (2#1111_011_0#, Sz); + Gen_Rm (Op, Val, Sz); + End_Insn; + end Gen_Mono_Op; + + procedure Emit_Mono_Op_Stmt (Op : Byte; Stmt : O_Enode; Sz : Insn_Size) + is + begin + Gen_Mono_Op (Op, Get_Expr_Operand (Stmt), Sz); + end Emit_Mono_Op_Stmt; + + procedure Emit_Load_Imm (Stmt : O_Enode; Sz : Insn_Size) + is + Tr : O_Reg; + begin + Tr := Get_Expr_Reg (Stmt); + Start_Insn; + -- FIXME: handle 0. + case Sz is + when Sz_8 => + Gen_B8 (2#1011_0_000# + To_Reg32 (Tr, Sz)); + when Sz_16 => + Gen_B8 (16#66#); + Gen_B8 (2#1011_1_000# + To_Reg32 (Tr, Sz)); + when Sz_32l + | Sz_32h => + Gen_B8 (2#1011_1_000# + To_Reg32 (Tr, Sz)); + end case; + Gen_Imm (Stmt, Sz); + End_Insn; + end Emit_Load_Imm; + + function Fp_Size_To_Mf (Sz : Fp_Size) return Byte is + begin + case Sz is + when Fp_32 => + return 2#00_0#; + when Fp_64 => + return 2#10_0#; + end case; + end Fp_Size_To_Mf; + + procedure Emit_Load_Fp (Stmt : O_Enode; Sz : Fp_Size) + is + Sym : Symbol; + begin + Set_Current_Section (Sect_Rodata); + Gen_Pow_Align (3); + Prealloc (8); + Sym := Create_Local_Symbol; + Set_Symbol_Pc (Sym, False); + Gen_Le32 (Unsigned_32 (Get_Expr_Low (Stmt))); + if Sz = Fp_64 then + Gen_Le32 (Unsigned_32 (Get_Expr_High (Stmt))); + end if; + Set_Current_Section (Sect_Text); + + Start_Insn; + Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz)); + Gen_B8 (2#00_000_101#); + Gen_X86_32 (Sym, 0); + End_Insn; + end Emit_Load_Fp; + + procedure Emit_Load_Fp_Mem (Stmt : O_Enode; Sz : Fp_Size) + is + begin + Start_Insn; + Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz)); + Gen_Rm_Mem (2#000_000#, Get_Expr_Operand (Stmt), Sz_32l); + End_Insn; + end Emit_Load_Fp_Mem; + + procedure Emit_Load_Mem (Stmt : O_Enode; Sz : Insn_Size) + is + Tr : O_Reg; + Val : O_Enode; + begin + Tr := Get_Expr_Reg (Stmt); + Val := Get_Expr_Operand (Stmt); + case Tr is + when Regs_R32 + | Regs_R64 => + -- mov REG, OP + Start_Insn; + Gen_Insn_Sz (2#1000_101_0#, Sz); + Gen_Rm_Mem (To_Reg32 (Tr, Sz) * 8, Val, Sz); + End_Insn; + when R_Eq => + -- Cmp OP, 1 + Start_Insn; + Gen_Insn_Sz_S8 (2#1000_000_0#, Sz); + Gen_Rm_Mem (2#111_000#, Val, Sz); + Gen_B8 (1); + End_Insn; + when others => + Error_Emit ("emit_load_mem", Stmt); + end case; + end Emit_Load_Mem; + + + procedure Emit_Store (Stmt : O_Enode; Sz : Insn_Size) + is + T, R : O_Enode; + Tr, Rr : O_Reg; + B : Byte; + begin + T := Get_Assign_Target (Stmt); + R := Get_Expr_Operand (Stmt); + Tr := Get_Expr_Reg (T); + Rr := Get_Expr_Reg (R); + Start_Insn; + case Rr is + when R_Imm => + if False and (Tr in Regs_R32 or Tr in Regs_R64) then + B := 2#1011_1_000#; + case Sz is + when Sz_8 => + B := B and not 2#0000_1_000#; + when Sz_16 => + Gen_B8 (16#66#); + when Sz_32l + | Sz_32h => + null; + end case; + Gen_B8 (B + To_Reg32 (Tr, Sz)); + else + Gen_Insn_Sz (2#1100_011_0#, Sz); + Gen_Rm_Mem (16#00#, T, Sz); + end if; + Gen_Imm (R, Sz); + when Regs_R32 + | Regs_R64 => + Gen_Insn_Sz (2#1000_100_0#, Sz); + Gen_Rm_Mem (To_Reg32 (Rr, Sz) * 8, T, Sz); + when others => + Error_Emit ("emit_store", Stmt); + end case; + End_Insn; + end Emit_Store; + + procedure Emit_Store_Fp (Stmt : O_Enode; Sz : Fp_Size) + is + begin + -- fstp + Start_Insn; + Gen_B8 (2#11011_00_1# + Fp_Size_To_Mf (Sz)); + Gen_Rm_Mem (2#011_000#, Get_Assign_Target (Stmt), Sz_32l); + End_Insn; + end Emit_Store_Fp; + + procedure Emit_Push_32 (Val : O_Enode; Sz : Insn_Size) + is + R : O_Reg; + begin + R := Get_Expr_Reg (Val); + Start_Insn; + case R is + when R_Imm => + if Is_Imm8 (Val, Sz) then + Gen_B8 (2#0110_1010#); + Gen_Imm8 (Val, Sz); + else + Gen_B8 (2#0110_1000#); + Gen_Imm (Val, Sz); + end if; + when Regs_R32 + | Regs_R64 => + Gen_B8 (2#01010_000# + To_Reg32 (R, Sz)); + when others => + Gen_B8 (2#1111_1111#); + Gen_Rm (2#110_000#, Val, Sz); + end case; + End_Insn; + end Emit_Push_32; + + procedure Emit_Pop_32 (Val : O_Enode; Sz : Insn_Size) + is + R : O_Reg; + begin + R := Get_Expr_Reg (Val); + Start_Insn; + case R is + when Regs_R32 + | Regs_R64 => + Gen_B8 (2#01011_000# + To_Reg32 (R, Sz)); + when others => + Gen_B8 (2#1000_1111#); + Gen_Rm (2#000_000#, Val, Sz); + end case; + End_Insn; + end Emit_Pop_32; + + procedure Emit_Push_Fp (Op : O_Enode; Sz : Fp_Size) + is + pragma Unreferenced (Op); + begin + Start_Insn; + -- subl esp, val + Gen_B8 (2#100000_11#); + Gen_B8 (2#11_101_100#); + case Sz is + when Fp_32 => + Gen_B8 (4); + when Fp_64 => + Gen_B8 (8); + end case; + End_Insn; + -- fstp st, (esp) + Start_Insn; + Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz)); + Gen_B8 (2#00_011_100#); + Gen_B8 (2#00_100_100#); + End_Insn; + end Emit_Push_Fp; + + function Prepare_Label (Label : O_Enode) return Symbol + is + Sym : Symbol; + begin + Sym := Get_Label_Symbol (Label); + if Sym = Null_Symbol then + Sym := Create_Local_Symbol; + Set_Label_Symbol (Label, Sym); + end if; + return Sym; + end Prepare_Label; + + procedure Emit_Jmp_T (Stmt : O_Enode; Reg : O_Reg) + is + Sym : Symbol; + Val : Pc_Type; + Opc : Byte; + begin + Sym := Prepare_Label (Get_Jump_Label (Stmt)); + Val := Get_Symbol_Value (Sym); + Start_Insn; + Opc := To_Cond (Reg); + if Val = 0 then + -- Assume long jmp. + Gen_B8 (16#0f#); + Gen_B8 (16#80# + Opc); + Gen_X86_Pc32 (Sym); + else + if Val + 128 < Get_Current_Pc + 4 then + -- Long jmp. + Gen_B8 (16#0f#); + Gen_B8 (16#80# + Opc); + Gen_Le32 (Unsigned_32 (Val - (Get_Current_Pc + 4))); + else + -- short jmp. + Gen_B8 (16#70# + Opc); + Gen_B8 (Byte (Val - (Get_Current_Pc + 1))); + end if; + end if; + End_Insn; + end Emit_Jmp_T; + + procedure Emit_Jmp (Stmt : O_Enode) + is + Sym : Symbol; + Val : Pc_Type; + begin + Sym := Prepare_Label (Get_Jump_Label (Stmt)); + Val := Get_Symbol_Value (Sym); + Start_Insn; + if Val = 0 then + -- Assume long jmp. + Gen_B8 (16#e9#); + Gen_X86_Pc32 (Sym); + else + if Val + 128 < Get_Current_Pc + 4 then + -- Long jmp. + Gen_B8 (16#e9#); + Gen_Le32 (Unsigned_32 (Val - (Get_Current_Pc + 4))); + else + -- short jmp. + Gen_B8 (16#eb#); + Gen_B8 (Byte ((Val - (Get_Current_Pc + 1)) and 16#Ff#)); + end if; + end if; + End_Insn; + end Emit_Jmp; + + procedure Emit_Label (Stmt : O_Enode) + is + Sym : Symbol; + begin + Sym := Prepare_Label (Stmt); + Set_Symbol_Pc (Sym, False); + end Emit_Label; + + procedure Gen_Call (Sym : Symbol) is + begin + Start_Insn; + Gen_B8 (16#E8#); + Gen_X86_Pc32 (Sym); + End_Insn; + end Gen_Call; + + procedure Emit_Call (Stmt : O_Enode) + is + use Ortho_Code.Decls; + Subprg : O_Dnode; + Sym : Symbol; + Val : Int32; + begin + Subprg := Get_Call_Subprg (Stmt); + Sym := Get_Decl_Symbol (Subprg); + Gen_Call (Sym); + Val := Get_Subprg_Stack (Subprg); + if Val /= 0 then + Start_Insn; + if Val <= 127 then + -- addl esp, val + Gen_B8 (2#100000_11#); + Gen_B8 (2#11_000_100#); + Gen_B8 (Byte (Val)); + else + -- addl esp, val + Gen_B8 (2#100000_01#); + Gen_B8 (2#11_000_100#); + Gen_Le32 (Unsigned_32 (Val)); + end if; + End_Insn; + end if; + end Emit_Call; + + procedure Emit_Intrinsic (Stmt : O_Enode) + is + Op : Int32; + begin + Op := Get_Intrinsic_Operation (Stmt); + Start_Insn; + Gen_B8 (16#E8#); + Gen_X86_Pc32 (Intrinsics_Symbol (Op)); + End_Insn; + + Start_Insn; + -- addl esp, val + Gen_B8 (2#100000_11#); + Gen_B8 (2#11_000_100#); + Gen_B8 (16); + End_Insn; + end Emit_Intrinsic; + + procedure Emit_Setcc (Dest : O_Enode; Cond : O_Reg) + is + begin + if Cond not in Regs_Cc then + raise Program_Error; + end if; + Start_Insn; + Gen_B8 (16#0f#); + Gen_B8 (16#90# + To_Cond (Cond)); + Gen_Rm (2#000_000#, Dest, Sz_8); + End_Insn; + end Emit_Setcc; + + procedure Emit_Setcc_Reg (Reg : O_Reg; Cond : O_Reg) + is + begin + if Cond not in Regs_Cc then + raise Program_Error; + end if; + Start_Insn; + Gen_B8 (16#0f#); + Gen_B8 (16#90# + To_Cond (Cond)); + Gen_B8 (2#11_000_000# + To_Reg32 (Reg, Sz_8)); + End_Insn; + end Emit_Setcc_Reg; + + procedure Emit_Tst (Reg : O_Reg; Sz : Insn_Size) + is + begin + Start_Insn; + Gen_Insn_Sz (2#1000_0100#, Sz); + Gen_B8 (2#11_000_000# + To_Reg32 (Reg, Sz) * 9); + End_Insn; + end Emit_Tst; + + procedure Gen_Cmp_Imm (Reg : O_Reg; Val : Int32; Sz : Insn_Size) + is + B : Byte; + begin + Start_Insn; + if Val <= 127 and Val >= -128 then + B := 2#10#; + else + B := 0; + end if; + Gen_Insn_Sz (2#1000_0000# + B, Sz); + Gen_B8 (2#11_111_000# + To_Reg32 (Reg)); + if B = 0 then + Gen_Le32 (Unsigned_32 (To_Uns32 (Val))); + else + Gen_B8 (Byte (To_Uns32 (Val) and 16#Ff#)); + end if; + End_Insn; + end Gen_Cmp_Imm; + + procedure Emit_Spill (Stmt : O_Enode; Sz : Insn_Size) + is + Reg : O_Reg; + Expr : O_Enode; + begin + Expr := Get_Expr_Operand (Stmt); + Reg := Get_Expr_Reg (Expr); + if Reg = R_Spill then + if Get_Expr_Kind (Expr) = OE_Conv then + return; + else + raise Program_Error; + end if; + end if; + Start_Insn; + Gen_Insn_Sz (2#1000_1000#, Sz); + Gen_Rm (To_Reg32 (Reg, Sz) * 8, Stmt, Sz); + End_Insn; + end Emit_Spill; + + procedure Emit_Load (Reg : O_Reg; Val : O_Enode; Sz : Insn_Size) + is + begin + Start_Insn; + Gen_Insn_Sz (2#1000_1010#, Sz); + Gen_Rm (To_Reg32 (Reg, Sz) * 8, Val, Sz); + End_Insn; + end Emit_Load; + + procedure Emit_Lea (Stmt : O_Enode) + is + Reg : O_Reg; + begin + -- Hack: change the register to use the real address instead of it. + Reg := Get_Expr_Reg (Stmt); + Set_Expr_Reg (Stmt, R_Mem); + + Start_Insn; + Gen_B8 (2#10001101#); + Gen_Rm_Mem (To_Reg32 (Reg) * 8, Stmt, Sz_32l); + End_Insn; + Set_Expr_Reg (Stmt, Reg); + end Emit_Lea; + + procedure Gen_Umul (Stmt : O_Enode; Sz : Insn_Size) + is + begin + if Get_Expr_Reg (Get_Expr_Left (Stmt)) /= R_Ax then + raise Program_Error; + end if; + Start_Insn; + Gen_Insn_Sz (16#F6#, Sz); + Gen_Rm (2#100_000#, Get_Expr_Right (Stmt), Sz); + End_Insn; + end Gen_Umul; + + procedure Gen_Mul (Stmt : O_Enode; Sz : Insn_Size) + is + Reg : O_Reg; + Right : O_Enode; + Reg_R : O_Reg; + begin + Reg := Get_Expr_Reg (Stmt); + Right := Get_Expr_Right (Stmt); + if Get_Expr_Reg (Get_Expr_Left (Stmt)) /= Reg + or Sz /= Sz_32l + then + raise Program_Error; + end if; + Start_Insn; + if Reg = R_Ax then + Gen_Insn_Sz (16#F6#, Sz); + Gen_Rm (2#100_000#, Right, Sz); + else + Reg_R := Get_Expr_Reg (Right); + case Reg_R is + when R_Imm => + if Is_Imm8 (Right, Sz) then + Gen_B8 (16#6B#); + Gen_B8 (To_Reg32 (Reg, Sz) * 9 or 2#11_000_000#); + Gen_Imm8 (Right, Sz); + else + Gen_B8 (16#69#); + Gen_B8 (To_Reg32 (Reg, Sz) * 9 or 2#11_000_000#); + Gen_Imm (Right, Sz); + end if; + when R_Mem + | R_Spill + | Regs_R32 => + Gen_B8 (16#0F#); + Gen_B8 (16#AF#); + Gen_Rm (To_Reg32 (Reg, Sz) * 8, Right, Sz); + when others => + Error_Emit ("gen_mul", Stmt); + end case; + end if; + End_Insn; + end Gen_Mul; + + -- Do not trap if COND is true. + procedure Gen_Ov_Check (Cond : O_Reg) is + begin + -- JXX +2 + Start_Insn; + Gen_B8 (16#70# + To_Cond (Cond)); + Gen_B8 (16#02#); + End_Insn; + -- INT 4 (overflow). + Start_Insn; + Gen_B8 (16#CD#); + Gen_B8 (16#04#); + End_Insn; + end Gen_Ov_Check; + + procedure Emit_Abs (Val : O_Enode; Mode : Mode_Type) + is + Szh : Insn_Size; + Pc_Jmp : Pc_Type; + begin + case Mode is + when Mode_I32 => + Szh := Sz_32l; + when Mode_I64 => + Szh := Sz_32h; + when others => + raise Program_Error; + end case; + Emit_Tst (Get_Expr_Reg (Val), Szh); + -- JXX + + Start_Insn; + Gen_B8 (16#70# + To_Cond (R_Sge)); + Gen_B8 (0); + End_Insn; + Pc_Jmp := Get_Current_Pc; + -- NEG + Gen_Mono_Op (2#011_000#, Val, Sz_32l); + if Mode = Mode_I64 then + -- Propagate carray. + -- Adc reg,0 + -- neg reg + Start_Insn; + Gen_B8 (2#100000_11#); + Gen_Rm (2#010_000#, Val, Sz_32h); + Gen_B8 (0); + End_Insn; + Gen_Mono_Op (2#011_000#, Val, Sz_32h); + end if; + Gen_Into; + Patch_B8 (Pc_Jmp - 1, Unsigned_8 (Get_Current_Pc - Pc_Jmp)); + end Emit_Abs; + + procedure Gen_Alloca (Stmt : O_Enode) + is + Reg : O_Reg; + begin + Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt)); + if Reg not in Regs_R32 or else Reg /= Get_Expr_Reg (Stmt) then + raise Program_Error; + end if; + -- Align stack on word. + -- Add reg, 3 + Start_Insn; + Gen_B8 (2#1000_0011#); + Gen_B8 (2#11_000_000# + To_Reg32 (Reg)); + Gen_B8 (3); + End_Insn; + -- and reg, ~3 + Start_Insn; + Gen_B8 (2#1000_0001#); + Gen_B8 (2#11_100_000# + To_Reg32 (Reg)); + Gen_Le32 (not 3); + End_Insn; + -- subl esp, reg + Start_Insn; + Gen_B8 (2#0001_1011#); + Gen_B8 (2#11_100_000# + To_Reg32 (Reg)); + End_Insn; + -- movl reg, esp + Start_Insn; + Gen_B8 (2#1000_1001#); + Gen_B8 (2#11_100_000# + To_Reg32 (Reg)); + End_Insn; + end Gen_Alloca; + + -- Byte/word to long. + procedure Gen_Movzx (Reg : Regs_R32; Op : O_Enode; Sz : Insn_Size) + is + B : Byte; + begin + Start_Insn; + Gen_B8 (16#0f#); + case Sz is + when Sz_8 => + B := 0; + when Sz_16 => + B := 1; + when Sz_32l + | Sz_32h => + raise Program_Error; + end case; + Gen_B8 (2#1011_0110# + B); + Gen_Rm (To_Reg32 (Reg) * 8, Op, Sz_8); + End_Insn; + end Gen_Movzx; + + -- Convert U32 to xx. + procedure Gen_Conv_U32 (Stmt : O_Enode) + is + Op : O_Enode; + Reg_Op : O_Reg; + Reg_Res : O_Reg; + begin + Op := Get_Expr_Operand (Stmt); + Reg_Op := Get_Expr_Reg (Op); + Reg_Res := Get_Expr_Reg (Stmt); + case Get_Expr_Mode (Stmt) is + when Mode_I32 => + if Reg_Res not in Regs_R32 then + raise Program_Error; + end if; + if Reg_Op /= Reg_Res then + Emit_Load (Reg_Res, Op, Sz_32l); + end if; + Emit_Tst (Reg_Res, Sz_32l); + Gen_Ov_Check (R_Sge); + when Mode_U8 + | Mode_B2 => + if Reg_Res not in Regs_R32 then + raise Program_Error; + end if; + if Reg_Op /= Reg_Res then + Emit_Load (Reg_Res, Op, Sz_32l); + end if; + -- cmpl VAL, 0xff + Start_Insn; + Gen_B8 (2#1000_0001#); + Gen_Rm (2#111_000#, Op, Sz_32l); + Gen_Le32 (16#00_00_00_Ff#); + End_Insn; + Gen_Ov_Check (R_Ule); + when others => + Error_Emit ("gen_conv_u32", Stmt); + end case; + end Gen_Conv_U32; + + -- Convert I32 to xxx + procedure Gen_Conv_I32 (Stmt : O_Enode) + is + Op : O_Enode; + Reg_Op : O_Reg; + Reg_Res : O_Reg; + begin + Op := Get_Expr_Operand (Stmt); + Reg_Op := Get_Expr_Reg (Op); + Reg_Res := Get_Expr_Reg (Stmt); + case Get_Expr_Mode (Stmt) is + when Mode_I64 => + if Reg_Res /= R_Edx_Eax or Reg_Op /= R_Ax then + raise Program_Error; + end if; + Gen_Cdq; + when Mode_U32 => + if Reg_Res not in Regs_R32 then + raise Program_Error; + end if; + if Reg_Op /= Reg_Res then + Emit_Load (Reg_Res, Op, Sz_32l); + end if; + Emit_Tst (Reg_Res, Sz_32l); + Gen_Ov_Check (R_Sge); + when Mode_B2 => + if Reg_Op /= Reg_Res then + Emit_Load (Reg_Res, Op, Sz_32l); + end if; + Gen_Cmp_Imm (Reg_Res, 1, Sz_32l); + Gen_Ov_Check (R_Ule); + when Mode_U8 => + if Reg_Op /= Reg_Res then + Emit_Load (Reg_Res, Op, Sz_32l); + end if; + Gen_Cmp_Imm (Reg_Res, 16#Ff#, Sz_32l); + Gen_Ov_Check (R_Ule); + when Mode_F64 => + Emit_Push_32 (Op, Sz_32l); + -- fild (%esp) + Start_Insn; + Gen_B8 (2#11011_011#); + Gen_B8 (2#00_000_100#); + Gen_B8 (2#00_100_100#); + End_Insn; + -- addl %esp, 4 + Start_Insn; + Gen_B8 (2#100000_11#); + Gen_B8 (2#11_000_100#); + Gen_B8 (4); + End_Insn; + when others => + Error_Emit ("gen_conv_i32", Stmt); + end case; + end Gen_Conv_I32; + + -- Convert U8 to xxx + procedure Gen_Conv_U8 (Stmt : O_Enode) + is + Op : O_Enode; + Reg_Op : O_Reg; + Reg_Res : O_Reg; + begin + Op := Get_Expr_Operand (Stmt); + Reg_Op := Get_Expr_Reg (Op); + Reg_Res := Get_Expr_Reg (Stmt); + case Get_Expr_Mode (Stmt) is + when Mode_U32 + | Mode_I32 + | Mode_U16 + | Mode_I16 => + if Reg_Res not in Regs_R32 then + raise Program_Error; + end if; + Gen_Movzx (Reg_Res, Op, Sz_8); + when others => + Error_Emit ("gen_conv_U8", Stmt); + end case; + end Gen_Conv_U8; + + -- Convert B2 to xxx + procedure Gen_Conv_B2 (Stmt : O_Enode) + is + Op : O_Enode; + Reg_Op : O_Reg; + Reg_Res : O_Reg; + begin + Op := Get_Expr_Operand (Stmt); + Reg_Op := Get_Expr_Reg (Op); + Reg_Res := Get_Expr_Reg (Stmt); + case Get_Expr_Mode (Stmt) is + when Mode_U32 + | Mode_I32 + | Mode_U16 + | Mode_I16 => + Gen_Movzx (Reg_Res, Op, Sz_8); + when others => + Error_Emit ("gen_conv_B2", Stmt); + end case; + end Gen_Conv_B2; + + -- Convert I64 to xxx + procedure Gen_Conv_I64 (Stmt : O_Enode) + is + Op : O_Enode; + Reg_Op : O_Reg; + Reg_Res : O_Reg; + begin + Op := Get_Expr_Operand (Stmt); + Reg_Op := Get_Expr_Reg (Op); + Reg_Res := Get_Expr_Reg (Stmt); + case Get_Expr_Mode (Stmt) is + when Mode_I32 => + -- move dx to reg_helper + Start_Insn; + Gen_B8 (2#1000_1001#); + Gen_B8 (2#11_010_000# + To_Reg32 (Reg_Helper)); + End_Insn; + Gen_Cdq; + -- cmp reg_helper, dx + Start_Insn; + Gen_B8 (2#0011_1001#); + Gen_B8 (2#11_010_000# + To_Reg32 (Reg_Helper)); + End_Insn; + Gen_Ov_Check (R_Eq); + when Mode_F64 => + Emit_Push_32 (Op, Sz_32h); + Emit_Push_32 (Op, Sz_32l); + -- fild (%esp) + Start_Insn; + Gen_B8 (2#11011_111#); + Gen_B8 (2#00_101_100#); + Gen_B8 (2#00_100_100#); + End_Insn; + -- addl %esp, 8 + Start_Insn; + Gen_B8 (2#100000_11#); + Gen_B8 (2#11_000_100#); + Gen_B8 (8); + End_Insn; + when others => + Error_Emit ("gen_conv_I64", Stmt); + end case; + end Gen_Conv_I64; + + -- Convert FP to xxx. + procedure Gen_Conv_Fp (Stmt : O_Enode) + is + Op : O_Enode; + begin + Op := Get_Expr_Operand (Stmt); + case Get_Expr_Mode (Stmt) is + when Mode_I32 => + -- subl %esp, 4 + Start_Insn; + Gen_B8 (2#100000_11#); + Gen_B8 (2#11_101_100#); + Gen_B8 (4); + End_Insn; + -- fistp (%esp) + Start_Insn; + Gen_B8 (2#11011_011#); + Gen_B8 (2#00_011_100#); + Gen_B8 (2#00_100_100#); + End_Insn; + Emit_Pop_32 (Stmt, Sz_32l); + when Mode_I64 => + -- subl %esp, 8 + Start_Insn; + Gen_B8 (2#100000_11#); + Gen_B8 (2#11_101_100#); + Gen_B8 (8); + End_Insn; + -- fistp (%esp) + Start_Insn; + Gen_B8 (2#11011_111#); + Gen_B8 (2#00_111_100#); + Gen_B8 (2#00_100_100#); + End_Insn; + Emit_Pop_32 (Stmt, Sz_32l); + Emit_Pop_32 (Stmt, Sz_32h); + when others => + Error_Emit ("gen_conv_fp", Stmt); + end case; + end Gen_Conv_Fp; + + procedure Gen_Emit_Op (Stmt : O_Enode; Cl : Byte; Ch : Byte) is + begin + case Get_Expr_Mode (Stmt) is + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Op (Cl, Stmt, Sz_32l); + when Mode_I64 + | Mode_U64 => + Emit_Op (Cl, Stmt, Sz_32l); + Emit_Op (Ch, Stmt, Sz_32h); + when Mode_B2 + | Mode_I8 + | Mode_U8 => + Emit_Op (Cl, Stmt, Sz_8); + when others => + Error_Emit ("gen_emit_op", Stmt); + end case; + end Gen_Emit_Op; + + procedure Gen_Check_Overflow (Mode : Mode_Type) is + begin + case Mode is + when Mode_I32 + | Mode_I64 + | Mode_I8 => + Gen_Into; + when Mode_U64 + | Mode_U32 + | Mode_U8 => + -- FIXME: check no carry. + null; + when Mode_B2 => + null; + when others => + raise Program_Error; + end case; + end Gen_Check_Overflow; + + procedure Gen_Emit_Fp_Op (Stmt : O_Enode; B_St1 : Byte; B_Mem : Byte) + is + Right : O_Enode; + Reg : O_Reg; + B_Size : Byte; + begin + Right := Get_Expr_Right (Stmt); + Reg := Get_Expr_Reg (Right); + Start_Insn; + case Reg is + when R_St0 => + Gen_B8 (2#11011_110#); + Gen_B8 (2#11_000_001# or B_St1); + when R_Mem => + case Get_Expr_Mode (Stmt) is + when Mode_F32 => + B_Size := 0; + when Mode_F64 => + B_Size := 2#100#; + when others => + raise Program_Error; + end case; + Gen_B8 (2#11011_000# or B_Size); + Gen_Rm_Mem (B_Mem, Right, Sz_32l); + when others => + raise Program_Error; + end case; + End_Insn; + end Gen_Emit_Fp_Op; + + procedure Emit_Mod (Stmt : O_Enode) + is + Right : O_Enode; + Pc1, Pc2, Pc3: Pc_Type; + begin + -- a : EAX + -- d : EDX + -- b : Rm + + -- d := Rm + -- d := d ^ a + -- cltd + -- if cc < 0 then + -- idiv b + -- if edx /= 0 then + -- edx := edx + b + -- end if + -- else + -- idiv b + -- end if + Right := Get_Expr_Right (Stmt); + -- %edx <- right + Emit_Load (R_Dx, Right, Sz_32l); + -- xorl %eax -> %edx + Start_Insn; + Gen_B8 (2#0011_0011#); + Gen_B8 (2#11_010_000#); + End_Insn; + Gen_Cdq; + -- js + Start_Insn; + Gen_B8 (2#0111_1000#); + Gen_B8 (0); + End_Insn; + Pc1 := Get_Current_Pc; + -- idiv + Gen_Mono_Op (2#111_000#, Right, Sz_32l); + -- jmp + Start_Insn; + Gen_B8 (2#1110_1011#); + Gen_B8 (0); + End_Insn; + Pc2 := Get_Current_Pc; + Patch_B8 (Pc1 - 1, Unsigned_8 (Get_Current_Pc - Pc1)); + -- idiv + Gen_Mono_Op (2#111_000#, Right, Sz_32l); + -- tstl %edx,%edx + Start_Insn; + Gen_B8 (2#1000_0101#); + Gen_B8 (2#11_010_010#); + End_Insn; + -- jz + Start_Insn; + Gen_B8 (2#0111_0100#); + Gen_B8 (0); + End_Insn; + Pc3 := Get_Current_Pc; + -- addl b, %edx + Start_Insn; + Gen_B8 (2#00_000_011#); + Gen_Rm (2#010_000#, Right, Sz_32l); + End_Insn; + Patch_B8 (Pc2 - 1, Unsigned_8 (Get_Current_Pc - Pc2)); + Patch_B8 (Pc3 - 1, Unsigned_8 (Get_Current_Pc - Pc3)); + end Emit_Mod; + + procedure Emit_Insn (Stmt : O_Enode) + is + use Ortho_Code.Flags; + Kind : OE_Kind; + Mode : Mode_Type; + Reg : O_Reg; + begin + Kind := Get_Expr_Kind (Stmt); + Mode := Get_Expr_Mode (Stmt); + case Kind is + when OE_Beg => + if Flag_Debug /= Debug_None then + Decls.Set_Block_Info1 (Get_Block_Decls (Stmt), + Int32 (Get_Current_Pc - Subprg_Pc)); + end if; + when OE_End => + if Flag_Debug /= Debug_None then + Decls.Set_Block_Info2 (Get_Block_Decls (Get_End_Beg (Stmt)), + Int32 (Get_Current_Pc - Subprg_Pc)); + end if; + when OE_Leave => + null; + when OE_BB => + null; + when OE_Add_Ov => + if Mode in Mode_Fp then + Gen_Emit_Fp_Op (Stmt, 2#000_000#, 2#000_000#); + else + Gen_Emit_Op (Stmt, 2#000_000#, 2#010_000#); + Gen_Check_Overflow (Mode); + end if; + when OE_Or => + Gen_Emit_Op (Stmt, 2#001_000#, 2#001_000#); + when OE_And => + Gen_Emit_Op (Stmt, 2#100_000#, 2#100_000#); + when OE_Xor => + Gen_Emit_Op (Stmt, 2#110_000#, 2#110_000#); + when OE_Sub_Ov => + if Mode in Mode_Fp then + Gen_Emit_Fp_Op (Stmt, 2#100_000#, 2#100_000#); + else + Gen_Emit_Op (Stmt, 2#101_000#, 2#011_000#); + Gen_Check_Overflow (Mode); + end if; + when OE_Mul_Ov + | OE_Mul => + case Mode is + when Mode_U8 => + Gen_Umul (Stmt, Sz_8); + when Mode_U16 => + Gen_Umul (Stmt, Sz_16); + when Mode_U32 => + Gen_Mul (Stmt, Sz_32l); + when Mode_I32 => + Gen_Mono_Op (2#101_000#, Get_Expr_Right (Stmt), Sz_32l); + when Mode_F32 + | Mode_F64 => + Gen_Emit_Fp_Op (Stmt, 2#001_000#, 2#001_000#); + when others => + Error_Emit ("emit_insn: mul_ov", Stmt); + end case; + when OE_Shl => + declare + Right : O_Enode; + Sz : Insn_Size; + Val : Uns32; + begin + case Mode is + when Mode_U32 => + Sz := Sz_32l; + when others => + Error_Emit ("emit_insn: shl", Stmt); + end case; + Right := Get_Expr_Right (Stmt); + if Get_Expr_Kind (Right) = OE_Const then + Val := Get_Expr_Low (Right); + Start_Insn; + if Val = 1 then + Gen_Insn_Sz (2#1101000_0#, Sz); + Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); + else + Gen_Insn_Sz (2#1100000_0#, Sz); + Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); + Gen_B8 (Byte (Val and 31)); + end if; + End_Insn; + else + if Get_Expr_Reg (Right) /= R_Cx then + raise Program_Error; + end if; + Start_Insn; + Gen_Insn_Sz (2#1101001_0#, Sz); + Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); + End_Insn; + end if; + end; + when OE_Mod + | OE_Rem + | OE_Div_Ov => + case Mode is + when Mode_U32 => + -- Xorl edx, edx + Start_Insn; + Gen_B8 (2#0011_0001#); + Gen_B8 (2#11_010_010#); + End_Insn; + Gen_Mono_Op (2#110_000#, Get_Expr_Right (Stmt), Sz_32l); + when Mode_I32 => + if Kind = OE_Mod then + Emit_Mod (Stmt); + else + Gen_Cdq; + Gen_Mono_Op (2#111_000#, Get_Expr_Right (Stmt), Sz_32l); + end if; + when Mode_F32 + | Mode_F64 => + if Kind = OE_Div_Ov then + Gen_Emit_Fp_Op (Stmt, 2#111_000#, 2#110_000#); + else + raise Program_Error; + end if; + when others => + Error_Emit ("emit_insn: mod_ov", Stmt); + end case; + + when OE_Not => + case Mode is + when Mode_B2 => + -- Xor VAL, $1 + Start_Insn; + Gen_B8 (2#1000_0011#); + Gen_Rm (2#110_000#, Stmt, Sz_8); + Gen_B8 (16#01#); + End_Insn; + when Mode_U8 => + Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_8); + when Mode_U16 => + Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_16); + when Mode_U32 => + Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32l); + when Mode_U64 => + Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32l); + Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32h); + when others => + Error_Emit ("emit_insn: not", Stmt); + end case; + + when OE_Neg_Ov => + case Mode is + when Mode_I8 => + Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_8); + --Gen_Into; + when Mode_I16 => + Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_16); + --Gen_Into; + when Mode_I32 => + Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32l); + --Gen_Into; + when Mode_I64 => + Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32l); + -- adcl 0, high + Start_Insn; + Gen_B8 (2#100000_11#); + Gen_Rm (2#010_000#, Get_Expr_Operand (Stmt), Sz_32h); + Gen_B8 (0); + End_Insn; + Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32h); + --Gen_Into; + when Mode_F32 + | Mode_F64 => + -- fchs + Start_Insn; + Gen_B8 (2#11011_001#); + Gen_B8 (2#1110_0000#); + End_Insn; + when others => + Error_Emit ("emit_insn: neg_ov", Stmt); + end case; + + when OE_Abs_Ov => + case Mode is + when Mode_I32 + | Mode_I64 => + Emit_Abs (Get_Expr_Operand (Stmt), Mode); + when Mode_F32 + | Mode_F64 => + -- fabs + Start_Insn; + Gen_B8 (2#11011_001#); + Gen_B8 (2#1110_0001#); + End_Insn; + when others => + Error_Emit ("emit_insn: abs_ov", Stmt); + end case; + + when OE_Kind_Cmp => + case Get_Expr_Mode (Get_Expr_Left (Stmt)) is + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Op (2#111_000#, Stmt, Sz_32l); + when Mode_B2 + | Mode_I8 + | Mode_U8 => + Emit_Op (2#111_000#, Stmt, Sz_8); + when Mode_U64 => + declare + Pc : Pc_Type; + begin + Emit_Op (2#111_000#, Stmt, Sz_32h); + -- jne + Start_Insn; + Gen_B8 (2#0111_0101#); + Gen_B8 (0); + End_Insn; + Pc := Get_Current_Pc; + Emit_Op (2#111_000#, Stmt, Sz_32l); + Patch_B8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc)); + end; + when Mode_I64 => + declare + Pc : Pc_Type; + begin + Reg := Get_Expr_Reg (Stmt); + Emit_Op (2#111_000#, Stmt, Sz_32h); + -- Note: this does not clobber a reg due to care in + -- insns. + Emit_Setcc_Reg (Reg, Ekind_Signed_To_Cc (Kind)); + -- jne + Start_Insn; + Gen_B8 (2#0111_0101#); + Gen_B8 (0); + End_Insn; + Pc := Get_Current_Pc; + Emit_Op (2#111_000#, Stmt, Sz_32l); + Emit_Setcc_Reg (Reg, Ekind_Unsigned_To_Cc (Kind)); + Patch_B8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc)); + return; + end; + when Mode_F32 + | Mode_F64 => + -- fcomip st, st(1) + Start_Insn; + Gen_B8 (2#11011_111#); + Gen_B8 (2#1111_0001#); + End_Insn; + -- fstp st, st (0) + Start_Insn; + Gen_B8 (2#11011_101#); + Gen_B8 (2#11_011_000#); + End_Insn; + when others => + Error_Emit ("emit_insn: cmp", Stmt); + end case; + Reg := Get_Expr_Reg (Stmt); + if Reg not in Regs_Cc then + Error_Emit ("emit_insn/cmp: not cc", Stmt); + end if; + when OE_Const + | OE_Addrg => + case Mode is + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Load_Imm (Stmt, Sz_32l); + when Mode_B2 + | Mode_U8 + | Mode_I8 => + Emit_Load_Imm (Stmt, Sz_8); + when Mode_I64 + | Mode_U64 => + Emit_Load_Imm (Stmt, Sz_32l); + Emit_Load_Imm (Stmt, Sz_32h); + when Mode_F32 => + Emit_Load_Fp (Stmt, Fp_32); + when Mode_F64 => + Emit_Load_Fp (Stmt, Fp_64); + when others => + Error_Emit ("emit_insn: const", Stmt); + end case; + when OE_Indir => + case Mode is + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Load_Mem (Stmt, Sz_32l); + when Mode_B2 + | Mode_U8 + | Mode_I8 => + Emit_Load_Mem (Stmt, Sz_8); + when Mode_U64 + | Mode_I64 => + Emit_Load_Mem (Stmt, Sz_32l); + Emit_Load_Mem (Stmt, Sz_32h); + when Mode_F32 => + Emit_Load_Fp_Mem (Stmt, Fp_32); + when Mode_F64 => + Emit_Load_Fp_Mem (Stmt, Fp_64); + when others => + Error_Emit ("emit_insn: indir", Stmt); + end case; + + when OE_Conv => + case Get_Expr_Mode (Get_Expr_Operand (Stmt)) is + when Mode_U32 => + Gen_Conv_U32 (Stmt); + when Mode_I32 => + Gen_Conv_I32 (Stmt); + when Mode_U8 => + Gen_Conv_U8 (Stmt); + when Mode_B2 => + Gen_Conv_B2 (Stmt); + when Mode_I64 => + Gen_Conv_I64 (Stmt); + when Mode_F32 + | Mode_F64 => + Gen_Conv_Fp (Stmt); + when others => + Error_Emit ("emit_insn: conv", Stmt); + end case; + + when OE_Asgn => + case Mode is + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Store (Stmt, Sz_32l); + when Mode_B2 + | Mode_U8 + | Mode_I8 => + Emit_Store (Stmt, Sz_8); + when Mode_U64 + | Mode_I64 => + Emit_Store (Stmt, Sz_32l); + Emit_Store (Stmt, Sz_32h); + when Mode_F32 => + Emit_Store_Fp (Stmt, Fp_32); + when Mode_F64 => + Emit_Store_Fp (Stmt, Fp_64); + when others => + Error_Emit ("emit_insn: move", Stmt); + end case; + + when OE_Jump_F => + Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt)); + if Reg not in Regs_Cc then + Error_Emit ("emit_insn/jmp_f: not cc", Stmt); + end if; + Emit_Jmp_T (Stmt, Inverse_Cc (Reg)); + when OE_Jump_T => + Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt)); + if Reg not in Regs_Cc then + Error_Emit ("emit_insn/jmp_t: not cc", Stmt); + end if; + Emit_Jmp_T (Stmt, Reg); + when OE_Jump => + Emit_Jmp (Stmt); + when OE_Label => + Emit_Label (Stmt); + + when OE_Ret => + -- Value already set. + null; + + when OE_Arg => + case Mode is + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32l); + when Mode_U64 + | Mode_I64 => + Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32h); + Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32l); + when Mode_F32 => + Emit_Push_Fp (Get_Expr_Operand (Stmt), Fp_32); + when Mode_F64 => + Emit_Push_Fp (Get_Expr_Operand (Stmt), Fp_64); + when others => + Error_Emit ("emit_insn: oe_arg", Stmt); + end case; + when OE_Call => + Emit_Call (Stmt); + when OE_Intrinsic => + Emit_Intrinsic (Stmt); + + when OE_Move => + declare + Operand : O_Enode; + Op_Reg : O_Reg; + begin + Reg := Get_Expr_Reg (Stmt); + Operand := Get_Expr_Operand (Stmt); + Op_Reg := Get_Expr_Reg (Operand); + case Mode is + when Mode_B2 => + if Reg in Regs_R32 and then Op_Reg in Regs_Cc then + Emit_Setcc (Stmt, Op_Reg); + elsif (Reg = R_Eq or Reg = R_Ne) + and then Op_Reg in Regs_R32 + then + Emit_Tst (Op_Reg, Sz_8); + else + Error_Emit ("emit_insn: move/b2", Stmt); + end if; + when Mode_U32 + | Mode_I32 => + -- mov REG, OP + Start_Insn; + Gen_Insn_Sz (2#1000_101_0#, Sz_32l); + Gen_Rm (To_Reg32 (Reg, Sz_32l) * 8, Operand, Sz_32l); + End_Insn; + when others => + Error_Emit ("emit_insn: move", Stmt); + end case; + end; + + when OE_Alloca => + if Mode /= Mode_P32 then + raise Program_Error; + end if; + Gen_Alloca (Stmt); + + when OE_Set_Stack => + Emit_Load_Mem (Stmt, Sz_32l); + + when OE_Add + | OE_Addrl => + case Mode is + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Lea (Stmt); + when others => + Error_Emit ("emit_insn: oe_add", Stmt); + end case; + + when OE_Spill => + case Mode is + when Mode_B2 + | Mode_U8 + | Mode_I8 => + Emit_Spill (Stmt, Sz_8); + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Spill (Stmt, Sz_32l); + when Mode_U64 + | Mode_I64 => + Emit_Spill (Stmt, Sz_32l); + Emit_Spill (Stmt, Sz_32h); + when others => + Error_Emit ("emit_insn: spill", Stmt); + end case; + + when OE_Reload => + declare + Expr : O_Enode; + begin + Reg := Get_Expr_Reg (Stmt); + Expr := Get_Expr_Operand (Stmt); + case Mode is + when Mode_B2 + | Mode_U8 + | Mode_I8 => + Emit_Load (Reg, Expr, Sz_8); + when Mode_U32 + | Mode_I32 + | Mode_P32 => + Emit_Load (Reg, Expr, Sz_32l); + when Mode_U64 + | Mode_I64 => + Emit_Load (Reg, Expr, Sz_32l); + Emit_Load (Reg, Expr, Sz_32h); + when others => + Error_Emit ("emit_insn: reload", Stmt); + end case; + end; + + when OE_Reg => + Reg_Helper := Get_Expr_Reg (Stmt); + + when OE_Case_Expr + | OE_Case => + null; + + when OE_Line => + if Flag_Debug = Debug_Dwarf then + Dwarf.Set_Line_Stmt (Get_Expr_Line_Number (Stmt)); + Set_Current_Section (Sect_Text); + end if; + when others => + Error_Emit ("cannot handle insn", Stmt); + end case; + end Emit_Insn; + + procedure Push_Reg_If_Used (Reg : Regs_R32) + is + use Ortho_Code.X86.Insns; + begin + if Reg_Used (Reg) then + Start_Insn; + Gen_B8 (2#01010_000# + To_Reg32 (Reg, Sz_32l)); + End_Insn; + end if; + end Push_Reg_If_Used; + + procedure Pop_Reg_If_Used (Reg : Regs_R32) + is + use Ortho_Code.X86.Insns; + begin + if Reg_Used (Reg) then + Start_Insn; + Gen_B8 (2#01011_000# + To_Reg32 (Reg, Sz_32l)); + End_Insn; + end if; + end Pop_Reg_If_Used; + + procedure Emit_Prologue (Subprg : Subprogram_Data_Acc) + is + use Ortho_Code.Decls; + use Binary_File; + use Interfaces; + use Flags; + Sym : Symbol; + Subprg_Decl : O_Dnode; + Is_Global : Boolean; + begin + Set_Current_Section (Sect_Text); + Subprg_Decl := Subprg.D_Decl; + Sym := Get_Decl_Symbol (Subprg_Decl); + case Get_Decl_Storage (Subprg_Decl) is + when O_Storage_Public + | O_Storage_External => + -- FIXME: should not accept the external case. + Is_Global := True; + when others => + Is_Global := False; + end case; + Set_Symbol_Pc (Sym, Is_Global); + Subprg_Pc := Get_Current_Pc; + +-- if Flag_Debug = Debug_Dwarf then +-- Dwarf.Emit_Prolog (Subprg); +-- Set_Current_Section (Sect_Text); +-- end if; + + -- Emit prolog. + -- push %ebp + Start_Insn; + Gen_B8 (2#01010_101#); + End_Insn; + -- movl %esp, %ebp + Start_Insn; + Gen_B8 (2#1000100_1#); + Gen_B8 (2#11_100_101#); + End_Insn; + -- subl XXX, %esp + if Subprg.Stack_Max /= 0 then + Start_Insn; + if Subprg.Stack_Max < 128 then + Gen_B8 (2#100000_11#); + Gen_B8 (2#11_101_100#); + Gen_B8 (Byte (Subprg.Stack_Max)); + else + Gen_B8 (2#100000_01#); + Gen_B8 (2#11_101_100#); + Gen_Le32 (Unsigned_32 (Subprg.Stack_Max)); + end if; + End_Insn; + end if; + + if Flag_Profile then + Gen_Call (Mcount_Symbol); + end if; + + -- Save registers. + Push_Reg_If_Used (R_Di); + Push_Reg_If_Used (R_Si); + Push_Reg_If_Used (R_Bx); + end Emit_Prologue; + + procedure Emit_Epilogue (Subprg : Subprogram_Data_Acc) + is + use Binary_File; + use Ortho_Code.Decls; + use Ortho_Code.Types; + use Flags; + Decl : O_Dnode; + begin + -- Restore registers. + Pop_Reg_If_Used (R_Bx); + Pop_Reg_If_Used (R_Si); + Pop_Reg_If_Used (R_Di); + + Decl := Subprg.D_Decl; + if Get_Decl_Kind (Decl) = OD_Function then + case Get_Type_Mode (Get_Decl_Type (Decl)) is + when Mode_U8 + | Mode_B2 => + -- movzx %al,%eax + Start_Insn; + Gen_B8 (16#0f#); + Gen_B8 (2#1011_0110#); + Gen_B8 (2#11_000_000#); + End_Insn; + when Mode_U32 + | Mode_I32 + | Mode_U64 + | Mode_I64 + | Mode_F32 + | Mode_F64 + | Mode_P32 => + null; + when others => + raise Program_Error; + end case; + end if; + + -- leave + Start_Insn; + Gen_B8 (2#1100_1001#); + End_Insn; + + -- ret + Start_Insn; + Gen_B8 (2#1100_0011#); + End_Insn; + + if Flag_Debug = Debug_Dwarf then + Set_Body_Info (Subprg.D_Body, Int32 (Get_Current_Pc - Subprg_Pc)); + end if; + end Emit_Epilogue; + + procedure Emit_Subprg (Subprg : Subprogram_Data_Acc) + is + Stmt : O_Enode; + begin + if Debug.Flag_Debug_Code2 then + Abi.Disp_Subprg_Decl (Subprg.D_Decl); + end if; + + Emit_Prologue (Subprg); + + Stmt := Subprg.E_Entry; + loop + Stmt := Get_Stmt_Link (Stmt); + + if Debug.Flag_Debug_Code2 then + Abi.Disp_Stmt (Stmt); + end if; + + Emit_Insn (Stmt); + exit when Get_Expr_Kind (Stmt) = OE_Leave; + end loop; + + Emit_Epilogue (Subprg); + end Emit_Subprg; + + procedure Emit_Var_Decl (Decl : O_Dnode) + is + use Decls; + use Types; + Sym : Symbol; + Storage : O_Storage; + Dtype : O_Tnode; + begin + Set_Current_Section (Sect_Bss); + Sym := Create_Symbol (Get_Decl_Ident (Decl)); + Set_Decl_Info (Decl, To_Int32 (Uns32 (Sym))); + Storage := Get_Decl_Storage (Decl); + Dtype := Get_Decl_Type (Decl); + case Storage is + when O_Storage_External => + null; + when O_Storage_Public + | O_Storage_Private => + Gen_Pow_Align (Get_Type_Align (Dtype)); + Set_Symbol_Pc (Sym, Storage = O_Storage_Public); + Gen_Space (Integer_32 (Get_Type_Size (Dtype))); + when O_Storage_Local => + raise Program_Error; + end case; + Set_Current_Section (Sect_Text); + end Emit_Var_Decl; + + procedure Emit_Const_Decl (Decl : O_Dnode) + is + use Decls; + use Types; + Sym : Symbol; + begin + Set_Current_Section (Sect_Rodata); + Sym := Create_Symbol (Get_Decl_Ident (Decl)); + Set_Decl_Info (Decl, To_Int32 (Uns32 (Sym))); + Set_Current_Section (Sect_Text); + end Emit_Const_Decl; + + procedure Emit_Const (Val : O_Cnode) + is + use Consts; + use Types; + H, L : Uns32; + begin + case Get_Const_Kind (Val) is + when OC_Signed + | OC_Unsigned + | OC_Float + | OC_Null + | OC_Lit => + Get_Const_Bytes (Val, H, L); + case Get_Type_Mode (Get_Const_Type (Val)) is + when Mode_U8 + | Mode_I8 + | Mode_B2 => + Gen_B8 (Byte (L)); + when Mode_U32 + | Mode_I32 + | Mode_F32 + | Mode_P32 => + Gen_Le32 (Unsigned_32 (L)); + when Mode_F64 + | Mode_I64 + | Mode_U64 => + Gen_Le32 (Unsigned_32 (L)); + Gen_Le32 (Unsigned_32 (H)); + when others => + raise Program_Error; + end case; + when OC_Address + | OC_Subprg_Address => + Gen_X86_32 (Get_Decl_Symbol (Get_Const_Decl (Val)), 0); + when OC_Array => + for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop + Emit_Const (Get_Const_Aggr_Element (Val, I)); + end loop; + when OC_Record => + declare + E : O_Cnode; + begin + for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop + E := Get_Const_Aggr_Element (Val, I); + Gen_Pow_Align (Get_Type_Align (Get_Const_Type (E))); + Emit_Const (E); + end loop; + end; + when OC_Sizeof => + raise Program_Error; + end case; + end Emit_Const; + + procedure Emit_Const_Value (Decl : O_Dnode; Val : O_Cnode) + is + use Decls; + use Types; + Sym : Symbol; + Dtype : O_Tnode; + begin + Set_Current_Section (Sect_Rodata); + Sym := Get_Decl_Symbol (Decl); + + Dtype := Get_Decl_Type (Decl); + Gen_Pow_Align (Get_Type_Align (Dtype)); + Set_Symbol_Pc (Sym, Get_Decl_Storage (Decl) = O_Storage_Public); + Prealloc (Pc_Type (Get_Type_Size (Dtype))); + Emit_Const (Val); + + Set_Current_Section (Sect_Text); + end Emit_Const_Value; + + procedure Init + is + use Ortho_Ident; + use Ortho_Code.Flags; + begin + Arch := Arch_X86; + + Create_Section (Sect_Text, ".text", Section_Exec + Section_Read); + Create_Section (Sect_Rodata, ".rodata", Section_Read); + Create_Section (Sect_Bss, ".bss", + Section_Read + Section_Write + Section_Zero); + + Set_Current_Section (Sect_Text); + + if Flag_Profile then + Mcount_Symbol := Create_Symbol (Get_Identifier ("mcount")); + end if; + + Intrinsics_Symbol (Intrinsic_Mul_Ov_U64) := + Create_Symbol (Get_Identifier ("__muldi3")); + Intrinsics_Symbol (Intrinsic_Div_Ov_U64) := + Create_Symbol (Get_Identifier ("__mcode_div_ov_u64")); + Intrinsics_Symbol (Intrinsic_Mod_Ov_U64) := + Create_Symbol (Get_Identifier ("__mcode_mod_ov_u64")); + Intrinsics_Symbol (Intrinsic_Mul_Ov_I64) := + Create_Symbol (Get_Identifier ("__muldi3")); + Intrinsics_Symbol (Intrinsic_Div_Ov_I64) := + Create_Symbol (Get_Identifier ("__divdi3")); + Intrinsics_Symbol (Intrinsic_Mod_Ov_I64) := + Create_Symbol (Get_Identifier ("__mcode_mod_ov_i64")); + Intrinsics_Symbol (Intrinsic_Rem_Ov_I64) := + Create_Symbol (Get_Identifier ("__mcode_rem_ov_i64")); + + if Debug.Flag_Debug_Asm then + Dump_Asm := True; + end if; + if Debug.Flag_Debug_Hex then + Debug_Hex := True; + end if; + + if Flag_Debug = Debug_Dwarf then + Dwarf.Init; + Set_Current_Section (Sect_Text); + end if; + end Init; + + procedure Finish + is + use Ortho_Code.Flags; + begin + if Flag_Debug = Debug_Dwarf then + Set_Current_Section (Sect_Text); + Dwarf.Finish; + end if; + end Finish; + +end Ortho_Code.X86.Emits; + diff --git a/ortho/mcode/ortho_code-x86-emits.ads b/ortho/mcode/ortho_code-x86-emits.ads new file mode 100644 index 0000000..dbad1c1 --- /dev/null +++ b/ortho/mcode/ortho_code-x86-emits.ads @@ -0,0 +1,35 @@ +-- Mcode back-end for ortho - Binary X86 instructions 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 Binary_File; use Binary_File; + +package Ortho_Code.X86.Emits is + procedure Init; + procedure Finish; + + procedure Emit_Subprg (Subprg : Subprogram_Data_Acc); + + procedure Emit_Var_Decl (Decl : O_Dnode); + procedure Emit_Const_Decl (Decl : O_Dnode); + procedure Emit_Const_Value (Decl : O_Dnode; Val : O_Cnode); + + type Intrinsic_Symbols_Map is array (Intrinsics_X86) of Symbol; + Intrinsics_Symbol : Intrinsic_Symbols_Map; + + Mcount_Symbol : Symbol; +end Ortho_Code.X86.Emits; + diff --git a/ortho/mcode/ortho_code-x86-insns.adb b/ortho/mcode/ortho_code-x86-insns.adb new file mode 100644 index 0000000..86fcb3c --- /dev/null +++ b/ortho/mcode/ortho_code-x86-insns.adb @@ -0,0 +1,1909 @@ +-- Mcode back-end for ortho - mcode to X86 instructions. +-- 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 Ada.Text_IO; +with Ortho_Code.Abi; +with Ortho_Code.Decls; use Ortho_Code.Decls; +with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Debug; + +package body Ortho_Code.X86.Insns is + procedure Link_Stmt (Stmt : O_Enode) + is + use Ortho_Code.Abi; + begin + Set_Stmt_Link (Last_Link, Stmt); + Last_Link := Stmt; + if Debug.Flag_Debug_Insn then + Disp_Stmt (Stmt); + end if; + end Link_Stmt; + + function Get_Reg_Any (Mode : Mode_Type) return O_Reg is + begin + case Mode is + when Mode_I16 .. Mode_I32 + | Mode_U16 .. Mode_U32 + | Mode_P32 => + return R_Any32; + when Mode_I8 + | Mode_U8 + | Mode_B2 => + return R_Any8; + when Mode_U64 + | Mode_I64 => + return R_Any64; + when Mode_F32 + | Mode_F64 => + return R_St0; + when Mode_P64 + | Mode_X1 + | Mode_Nil + | Mode_Blk => + raise Program_Error; + end case; + end Get_Reg_Any; + + function Get_Reg_Any (Stmt : O_Enode) return O_Reg is + begin + return Get_Reg_Any (Get_Expr_Mode (Stmt)); + end Get_Reg_Any; + + -- Stack slot management. + Stack_Offset : Uns32 := 0; + Stack_Max : Uns32 := 0; + + -- STMT is an OE_END statement. + -- Swap Stack_Offset with Max_Stack of STMT. + procedure Swap_Stack_Offset (Blk : O_Dnode) + is + use Ortho_Code.Decls; + + Prev_Offset : Uns32; + begin + Prev_Offset := Get_Block_Max_Stack (Blk); + Set_Block_Max_Stack (Blk, Stack_Offset); + Stack_Offset := Prev_Offset; + end Swap_Stack_Offset; + + procedure Expand_Decls (Block : O_Dnode) + is + Last : O_Dnode; + Decl : O_Dnode; + Decl_Type : O_Tnode; + begin + if Get_Decl_Kind (Block) /= OD_Block then + raise Program_Error; + end if; + Last := Get_Block_Last (Block); + Decl := Block + 1; + while Decl <= Last loop + case Get_Decl_Kind (Decl) is + when OD_Local => + Decl_Type := Get_Decl_Type (Decl); + Stack_Offset := Do_Align (Stack_Offset, Decl_Type); + Stack_Offset := Stack_Offset + Get_Type_Size (Decl_Type); + Set_Local_Offset (Decl, -Int32 (Stack_Offset)); + if Stack_Offset > Stack_Max then + Stack_Max := Stack_Offset; + end if; + when OD_Type + | OD_Const + | OD_Const_Val + | OD_Var + | OD_Function + | OD_Procedure + | OD_Interface + | OD_Body => + null; + when OD_Block => + Decl := Get_Block_Last (Decl); + end case; + Decl := Decl + 1; + end loop; + end Expand_Decls; + + function Ekind_To_Cc (Stmt : O_Enode; Mode : Mode_Type) return O_Reg + is + Kind : OE_Kind; + begin + Kind := Get_Expr_Kind (Stmt); + case Mode is + when Mode_U8 .. Mode_U64 + | Mode_F32 .. Mode_F64 + | Mode_P32 + | Mode_P64 + | Mode_B2 => + return Ekind_Unsigned_To_Cc (Kind); + when Mode_I8 .. Mode_I64 => + return Ekind_Signed_To_Cc (Kind); + when others => + raise Program_Error; + end case; + end Ekind_To_Cc; + + -- CC is the result of A CMP B. + -- Returns the condition for B CMP A. + function Reverse_Cc (Cc : O_Reg) return O_Reg is + begin + case Cc is + when R_Ult => + return R_Ugt; + when R_Uge => + return R_Ule; + when R_Eq => + return R_Eq; + when R_Ne => + return R_Ne; + when R_Ule => + return R_Uge; + when R_Ugt => + return R_Ult; + when R_Slt => + return R_Sgt; + when R_Sge => + return R_Sle; + when R_Sle => + return R_Sge; + when R_Sgt => + return R_Slt; + when others => + raise Program_Error; + end case; + end Reverse_Cc; + + function Get_Call_Register (Mode : Mode_Type) return O_Reg is + begin + case Mode is + when Mode_U8 .. Mode_U32 + | Mode_I8 .. Mode_I32 + | Mode_P32 + | Mode_B2 => + return R_Ax; + when Mode_U64 + | Mode_I64 => + return R_Edx_Eax; + when Mode_F32 + | Mode_F64 => + return R_St0; + when Mode_Nil => + return R_None; + when Mode_X1 + | Mode_Blk + | Mode_P64 => + raise Program_Error; + end case; + end Get_Call_Register; + +-- function Ensure_Rm (Stmt : O_Enode) return O_Enode +-- is +-- begin +-- case Get_Expr_Reg (Stmt) is +-- when R_Mem +-- | Regs_Any32 => +-- return Stmt; +-- when others => +-- raise Program_Error; +-- end case; +-- end Ensure_Rm; + +-- function Ensure_Ireg (Stmt : O_Enode) return O_Enode +-- is +-- Reg : O_Reg; +-- begin +-- Reg := Get_Expr_Reg (Stmt); +-- case Reg is +-- when Regs_Any32 +-- | R_Imm => +-- return Stmt; +-- when others => +-- raise Program_Error; +-- end case; +-- end Ensure_Ireg; + + function Insert_Move (Expr : O_Enode; Dest : O_Reg) return O_Enode + is + N : O_Enode; + begin + N := New_Enode (OE_Move, Get_Expr_Mode (Expr), O_Tnode_Null, + Expr, O_Enode_Null); + Set_Expr_Reg (N, Dest); + Link_Stmt (N); + return N; + end Insert_Move; + + function Insert_Spill (Expr : O_Enode) return O_Enode + is + N : O_Enode; + begin + N := New_Enode (OE_Spill, Get_Expr_Mode (Expr), O_Tnode_Null, + Expr, O_Enode_Null); + Set_Expr_Reg (N, R_Spill); + Link_Stmt (N); + return N; + end Insert_Spill; + + procedure Error_Gen_Insn (Stmt : O_Enode; Reg : O_Reg) + is + use Ada.Text_IO; + begin + Put_Line ("gen_insn error: cannot match reg " & Abi.Image_Reg (Reg) + & " with stmt " & OE_Kind'Image (Get_Expr_Kind (Stmt))); + raise Program_Error; + end Error_Gen_Insn; + + procedure Error_Gen_Insn (Stmt : O_Enode; Mode : Mode_Type) + is + use Ada.Text_IO; + begin + Put_Line ("gen_insn error: cannot match mode " & Mode_Type'Image (Mode) + & " with stmt " & OE_Kind'Image (Get_Expr_Kind (Stmt)) + & " of mode " & Mode_Type'Image (Get_Expr_Mode (Stmt))); + raise Program_Error; + end Error_Gen_Insn; + + pragma No_Return (Error_Gen_Insn); + + Cur_Block : O_Enode; + + type O_Inum is new Int32; + O_Free : constant O_Inum := 0; + O_Iroot : constant O_Inum := 1; + + + Insn_Num : O_Inum; + + function Get_Insn_Num return O_Inum is + begin + Insn_Num := Insn_Num + 1; + return Insn_Num; + end Get_Insn_Num; + + + type Reg_Info_Type is record + -- Statement number which use this register. + -- This is a distance. + Num : O_Inum; + + -- Statement which produces this value. + -- Used to have more info on this register (such as mode to allocate + -- a spill location). + Stmt : O_Enode; + + -- If set, this register has been used. + -- All callee-saved registers marked must be saved. + Used : Boolean; + end record; + + Init_Reg_Info : Reg_Info_Type := (Num => O_Free, + Stmt => O_Enode_Null, + Used => False); + type Reg32_Info_Array is array (Regs_R32) of Reg_Info_Type; + Regs : Reg32_Info_Array := (others => Init_Reg_Info); + Reg_Cc : Reg_Info_Type := Init_Reg_Info; + + type Fp_Stack_Type is mod 8; + type RegFp_Info_Array is array (Fp_Stack_Type) of Reg_Info_Type; + Fp_Top : Fp_Stack_Type := 0; + Fp_Regs : RegFp_Info_Array; + + + function Reg_Used (Reg : Regs_R32) return Boolean is + begin + return Regs (Reg).Used; + end Reg_Used; + + + procedure Dump_Reg_Info (Reg : Regs_R32) + is + use Ada.Text_IO; + use Ortho_Code.Debug.Int32_IO; + use Abi; + begin + Put (Image_Reg (Reg)); + Put (": "); + Put (Int32 (Regs (Reg).Stmt), 0); + Put (", num: "); + Put (Int32 (Regs (Reg).Num), 0); + --Put (", twin: "); + --Put (Image_Reg (Regs (Reg).Twin_Reg)); + --Put (", link: "); + --Put (Image_Reg (Regs (Reg).Link)); + New_Line; + end Dump_Reg_Info; + + procedure Dump_Regs + is + use Ada.Text_IO; + use Debug.Int32_IO; + begin +-- Put ("free_regs: "); +-- Put (Image_Reg (Free_Regs)); +-- Put (", to_free_regs: "); +-- Put (Image_Reg (To_Free_Regs)); +-- New_Line; + + for I in Regs_R32 loop + Dump_Reg_Info (I); + end loop; + for I in Fp_Stack_Type loop + Put ("fp" & Fp_Stack_Type'Image (I)); + Put (": "); + Put (Int32 (Fp_Regs (I).Stmt), 0); + New_Line; + end loop; + end Dump_Regs; + + procedure Error_Reg (Msg : String; Stmt : O_Enode; Reg : O_Reg) + is + use Ada.Text_IO; + use Ortho_Code.Debug.Int32_IO; + begin + Put ("error reg: "); + Put (Msg); + New_Line; + Put (" stmt: "); + Put (Int32 (Stmt), 0); + Put (", reg: "); + Put (Abi.Image_Reg (Reg)); + New_Line; + --Dump_Regs; + raise Program_Error; + end Error_Reg; + pragma No_Return (Error_Reg); + + procedure Free_R32 (Reg : O_Reg) is + begin + if Regs (Reg).Num = O_Free then + raise Program_Error; + end if; + Regs (Reg).Num := O_Free; + end Free_R32; + + procedure Free_Fp is + begin + if Fp_Regs (Fp_Top).Stmt = O_Enode_Null then + raise Program_Error; + end if; + Fp_Regs (Fp_Top).Stmt := O_Enode_Null; + Fp_Top := Fp_Top + 1; + end Free_Fp; + + procedure Free_Cc is + begin + if Reg_Cc.Num = O_Free then + raise Program_Error; + end if; + Reg_Cc.Num := O_Free; + end Free_Cc; + + procedure Alloc_Spill (N : O_Enode) + is + Mode : Mode_Type; + begin + Mode := Get_Expr_Mode (N); + -- Allocate on the stack. + Stack_Offset := Types.Do_Align (Stack_Offset, Mode); + Stack_Offset := Stack_Offset + Types.Get_Mode_Size (Mode); + if Stack_Offset > Stack_Max then + Stack_Max := Stack_Offset; + end if; + Set_Spill_Info (N, -Int32 (Stack_Offset)); + end Alloc_Spill; + + procedure Spill_R32 (Reg : Regs_R32) + is + N : O_Enode; + Orig : O_Enode; + Mode : Mode_Type; + Reg_Orig : O_Reg; + begin + Orig := Regs (Reg).Stmt; + if Orig = O_Enode_Null then + -- This register was not allocated. + raise Program_Error; + end if; + + -- Add a spill statement. + Mode := Get_Expr_Mode (Orig); + N := New_Enode (OE_Spill, Mode, O_Tnode_Null, Orig, O_Enode_Null); + Alloc_Spill (N); + + -- Insert the statement after the one that set the register + -- being spilled. + -- That's very important to be able to easily find the spill location, + -- when it will be reloaded. + if Orig = Abi.Last_Link then + Link_Stmt (N); + else + Set_Stmt_Link (N, Get_Stmt_Link (Orig)); + Set_Stmt_Link (Orig, N); + end if; + Reg_Orig := Get_Expr_Reg (Orig); + Set_Expr_Reg (N, Reg_Orig); + Set_Expr_Reg (Orig, R_Spill); + + -- Free the register. + case Reg_Orig is + when Regs_R32 => + if Reg_Orig /= Reg then + raise Program_Error; + end if; + Free_R32 (Reg); + when Regs_R64 => + Free_R32 (Get_R64_High (Reg_Orig)); + Free_R32 (Get_R64_Low (Reg_Orig)); + when others => + raise Program_Error; + end case; + end Spill_R32; + + procedure Alloc_R32 (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) is + begin + if Regs (Reg).Num /= O_Free then + Spill_R32 (Reg); + end if; + Regs (Reg) := (Num => Num, Stmt => Stmt, Used => True); + end Alloc_R32; + + procedure Clobber_R32 (Reg : O_Reg) is + begin + if Regs (Reg).Num /= O_Free then + Spill_R32 (Reg); + end if; + end Clobber_R32; + + procedure Alloc_Fp (Stmt : O_Enode) + is + begin + Fp_Top := Fp_Top - 1; + + if Fp_Regs (Fp_Top).Stmt /= O_Enode_Null then + -- Must spill-out. + raise Program_Error; + end if; + Fp_Regs (Fp_Top).Stmt := Stmt; + end Alloc_Fp; + + procedure Alloc_R64 (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) + is + Rh, Rl : O_Reg; + begin + Rl := Get_R64_Low (Reg); + Rh := Get_R64_High (Reg); + if Regs (Rl).Num /= O_Free + or Regs (Rh).Num /= O_Free + then + Spill_R32 (Rl); + end if; + Regs (Rh) := (Num => Num, Stmt => Stmt, Used => True); + Regs (Rl) := (Num => Num, Stmt => Stmt, Used => True); + end Alloc_R64; + + procedure Alloc_Cc (Stmt : O_Enode; Num : O_Inum) is + begin + if Reg_Cc.Num /= O_Free then + raise Program_Error; + end if; + Reg_Cc := (Num => Num, Stmt => Stmt, Used => True); + end Alloc_Cc; + + function Alloc_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) return O_Reg + is + Best_Reg : O_Reg; + Best_Num : O_Inum; + begin + case Reg is + when Regs_R32 => + Alloc_R32 (Reg, Stmt, Num); + return Reg; + when Regs_R64 => + Alloc_R64 (Reg, Stmt, Num); + return Reg; + when R_St0 => + Alloc_Fp (Stmt); + return Reg; + when R_Any32 => + Best_Num := O_Inum'Last; + Best_Reg := R_None; + for I in Regs_R32 loop + if I not in R_Sp .. R_Bp then + if Regs (I).Num = O_Free then + Alloc_R32 (I, Stmt, Num); + return I; + elsif Regs (I).Num <= Best_Num then + Best_Reg := I; + Best_Num := Regs (I).Num; + end if; + end if; + end loop; + Alloc_R32 (Best_Reg, Stmt, Num); + return Best_Reg; + when R_Any8 => + Best_Num := O_Inum'Last; + Best_Reg := R_None; + for I in Regs_R8 loop + if Regs (I).Num = O_Free then + Alloc_R32 (I, Stmt, Num); + return I; + elsif Regs (I).Num <= Best_Num then + Best_Reg := I; + Best_Num := Regs (I).Num; + end if; + end loop; + Alloc_R32 (Best_Reg, Stmt, Num); + return Best_Reg; + when R_Any64 => + declare + Rh, Rl : O_Reg; + begin + Best_Num := O_Inum'Last; + Best_Reg := R_None; + for I in Regs_R64 loop + Rh := Get_R64_High (I); + Rl := Get_R64_Low (I); + if Regs (Rh).Num = O_Free + and then Regs (Rl).Num = O_Free + then + Alloc_R64 (I, Stmt, Num); + return I; + elsif Regs (Rh).Num <= Best_Num + and Regs (Rl).Num <= Best_Num + then + Best_Reg := I; + Best_Num := O_Inum'Max (Regs (Rh).Num, + Regs (Rl).Num); + end if; + end loop; + Alloc_R64 (Best_Reg, Stmt, Num); + return Best_Reg; + end; + when others => + Error_Reg ("alloc_reg: unknown reg", O_Enode_Null, Reg); + raise Program_Error; + end case; + end Alloc_Reg; + + function Gen_Reload (Spill : O_Enode; Reg : O_Reg; Num : O_Inum) + return O_Enode + is + N : O_Enode; + Mode : Mode_Type; + begin + -- Add a reload node. + Mode := Get_Expr_Mode (Spill); + N := New_Enode (OE_Reload, Mode, O_Tnode_Null, Spill, O_Enode_Null); + -- Note: this does not use a just-freed register, since + -- this case only occurs at the first call. + Set_Expr_Reg (N, Alloc_Reg (Reg, N, Num)); + Link_Stmt (N); + return N; + end Gen_Reload; + + function Reload (Expr : O_Enode; Dest : O_Reg; Num : O_Inum) return O_Enode + is + Reg : O_Reg; + Spill : O_Enode; + begin + Reg := Get_Expr_Reg (Expr); + case Reg is + when R_Spill => + -- Restore the register between the statement and the spill. + Spill := Get_Stmt_Link (Expr); + Set_Expr_Reg (Expr, Get_Expr_Reg (Spill)); + Set_Expr_Reg (Spill, R_Spill); + case Dest is + when R_Mem + | R_Irm + | R_Rm => + return Spill; + when Regs_R32 + | R_Any32 + | Regs_R64 + | R_Any64 + | R_Any8 => + return Gen_Reload (Spill, Dest, Num); + when R_Sib => + return Gen_Reload (Spill, R_Any32, Num); + when R_Ir => + return Gen_Reload (Spill, Get_Reg_Any (Expr), Num); + when others => + Error_Reg ("reload: unhandled dest in spill", Expr, Dest); + end case; + when Regs_R32 => + case Dest is + when R_Irm + | R_Rm + | R_Ir + | R_Any32 + | R_Any8 + | R_Sib => + return Expr; + when Regs_R32 => + if Dest = Reg then + return Expr; + end if; + Free_R32 (Reg); + return Insert_Move (Expr, Alloc_Reg (Dest, Expr, Num)); + when others => + Error_Reg ("reload: unhandled dest in R32", Expr, Dest); + end case; + when Regs_R64 => + return Expr; + when R_St0 => + return Expr; + when R_Mem => + if Get_Expr_Kind (Expr) = OE_Indir then + Set_Expr_Operand (Expr, + Reload (Get_Expr_Operand (Expr), R_Sib, Num)); + return Expr; + else + raise Program_Error; + end if; + when R_B_Off + | R_B_I + | R_I_Off + | R_Sib => + case Get_Expr_Kind (Expr) is + when OE_Add => + Set_Expr_Left + (Expr, Reload (Get_Expr_Left (Expr), R_Any32, Num)); + Set_Expr_Right + (Expr, Reload (Get_Expr_Right (Expr), R_Any32, Num)); + return Expr; + when OE_Addrl => + Spill := Get_Addrl_Frame (Expr); + if Spill /= O_Enode_Null then + Set_Addrl_Frame (Expr, Reload (Spill, R_Any32, Num)); + end if; + return Expr; + when others => + Error_Reg ("reload: unhandle expr in b_off", Expr, Dest); + end case; + when R_I => + Set_Expr_Left (Expr, Reload (Get_Expr_Left (Expr), R_Any32, Num)); + return Expr; + when R_Imm => + return Expr; + when others => + Error_Reg ("reload: unhandled reg", Expr, Reg); + end case; + end Reload; + + procedure Renum_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) is + begin + case Reg is + when Regs_R32 => + Regs (Reg).Num := Num; + Regs (Reg).Stmt := Stmt; + when Regs_Cc => + Reg_Cc.Num := Num; + Reg_Cc.Stmt := Stmt; + when R_St0 => + null; + when Regs_R64 => + declare + L, H : O_Reg; + begin + L := Get_R64_Low (Reg); + Regs (L).Num := Num; + Regs (L).Stmt := Stmt; + H := Get_R64_High (Reg); + Regs (H).Num := Num; + Regs (H).Stmt := Stmt; + end; + when others => + Error_Reg ("renum_reg", Stmt, Reg); + end case; + end Renum_Reg; + + procedure Free_Insn_Regs (Insn : O_Enode) + is + R : O_Reg; + begin + R := Get_Expr_Reg (Insn); + case R is + when R_Ax + | R_Bx + | R_Cx + | R_Dx + | R_Si + | R_Di => + Free_R32 (R); + when R_Sp + | R_Bp => + null; + when R_St0 => + Free_Fp; + when Regs_R64 => + Free_R32 (Get_R64_High (R)); + Free_R32 (Get_R64_Low (R)); + when R_Mem => + if Get_Expr_Kind (Insn) = OE_Indir then + Free_Insn_Regs (Get_Expr_Operand (Insn)); + else + raise Program_Error; + end if; + when R_B_Off + | R_B_I + | R_I_Off + | R_Sib => + case Get_Expr_Kind (Insn) is + when OE_Add => + Free_Insn_Regs (Get_Expr_Left (Insn)); + Free_Insn_Regs (Get_Expr_Right (Insn)); + when OE_Addrl => + if Get_Addrl_Frame (Insn) /= O_Enode_Null then + Free_Insn_Regs (Get_Addrl_Frame (Insn)); + end if; + when others => + raise Program_Error; + end case; + when R_I => + Free_Insn_Regs (Get_Expr_Left (Insn)); + when R_Imm => + null; + when R_Spill => + null; + when others => + Error_Reg ("free_insn_regs: unknown reg", Insn, R); + end case; + end Free_Insn_Regs; + + procedure Insert_Reg (Mode : Mode_Type) + is + N : O_Enode; + Num : O_Inum; + begin + Num := Get_Insn_Num; + N := New_Enode (OE_Reg, Mode, O_Tnode_Null, + O_Enode_Null, O_Enode_Null); + Set_Expr_Reg (N, Alloc_Reg (Get_Reg_Any (Mode), N, Num)); + Link_Stmt (N); + Free_Insn_Regs (N); + end Insert_Reg; + + procedure Insert_Arg (Expr : O_Enode) + is + N : O_Enode; + begin + Free_Insn_Regs (Expr); + N := New_Enode (OE_Arg, Get_Expr_Mode (Expr), O_Tnode_Null, + Expr, O_Enode_Null); + Set_Expr_Reg (N, R_None); + Link_Stmt (N); + end Insert_Arg; + + function Insert_Intrinsic (Stmt : O_Enode; Reg : O_Reg; Num : O_Inum) + return O_Enode + is + N : O_Enode; + Op : Int32; + Mode : Mode_Type; + begin + Mode := Get_Expr_Mode (Stmt); + case Get_Expr_Kind (Stmt) is + when OE_Mul_Ov => + case Mode is + when Mode_U64 => + Op := Intrinsic_Mul_Ov_U64; + when Mode_I64 => + Op := Intrinsic_Mul_Ov_I64; + when others => + raise Program_Error; + end case; + when OE_Div_Ov => + case Mode is + when Mode_U64 => + Op := Intrinsic_Div_Ov_U64; + when Mode_I64 => + Op := Intrinsic_Div_Ov_I64; + when others => + raise Program_Error; + end case; + when OE_Mod => + case Mode is + when Mode_U64 => + Op := Intrinsic_Mod_Ov_U64; + when Mode_I64 => + Op := Intrinsic_Mod_Ov_I64; + when others => + raise Program_Error; + end case; + when OE_Rem => + case Mode is + when Mode_U64 => + -- For unsigned, MOD == REM. + Op := Intrinsic_Mod_Ov_U64; + when Mode_I64 => + Op := Intrinsic_Rem_Ov_I64; + when others => + raise Program_Error; + end case; + when others => + raise Program_Error; + end case; + + -- Save caller-saved registers. + Clobber_R32 (R_Ax); + Clobber_R32 (R_Dx); + Clobber_R32 (R_Cx); + + N := New_Enode (OE_Intrinsic, Mode, O_Tnode_Null, + O_Enode (Op), O_Enode_Null); + Set_Expr_Reg (N, Alloc_Reg (Reg, N, Num)); + Link_Stmt (N); + return N; + end Insert_Intrinsic; + + function Gen_Insn (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum) + return O_Enode; + + function Gen_Conv_From_Fp_Insn (Stmt : O_Enode; + Reg : O_Reg; + Pnum : O_Inum) + return O_Enode + is + Num : O_Inum; + Left : O_Enode; + begin + Left := Get_Expr_Operand (Stmt); + Num := Get_Insn_Num; + Left := Gen_Insn (Left, R_St0, Num); + Free_Insn_Regs (Left); + Set_Expr_Operand (Stmt, Left); + case Reg is + when Regs_R32 + | R_Any32 + | Regs_R64 + | R_Any64 => + Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); + when R_Rm + | R_Irm + | R_Ir => + Set_Expr_Reg (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum)); + when others => + raise Program_Error; + end case; + Link_Stmt (Stmt); + return Stmt; +-- declare +-- Spill : O_Enode; +-- begin +-- Num := Get_Insn_Num; +-- Left := Gen_Insn (Left, R_St0, Num); +-- Set_Expr_Operand (Stmt, Left); +-- Set_Expr_Reg (Stmt, R_Spill); +-- Free_Insn_Regs (Left); +-- Link_Stmt (Stmt); +-- Spill := Insert_Spill (Stmt); +-- case Reg is +-- when R_Any32 +-- | Regs_R32 => +-- return Gen_Reload (Spill, Reg, Pnum); +-- when R_Ir => +-- return Gen_Reload (Spill, R_Any32, Pnum); +-- when R_Rm +-- | R_Irm => +-- return Spill; +-- when others => +-- Error_Reg +-- ("gen_insn:oe_conv(fp)", Stmt, Reg); +-- end case; +-- end; + end Gen_Conv_From_Fp_Insn; + + function Gen_Insn (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum) + return O_Enode + is + Kind : OE_Kind; + + Left : O_Enode; + Right : O_Enode; + + Reg1 : O_Reg; + -- P_Reg : O_Reg; + Reg_L : O_Reg; + Reg_Res : O_Reg; + + Num : O_Inum; + begin + Kind := Get_Expr_Kind (Stmt); + case Kind is + when OE_Addrl => + Right := Get_Addrl_Frame (Stmt); + if Right /= O_Enode_Null then + Num := Get_Insn_Num; + Right := Gen_Insn (Right, R_Any32, Num); + Set_Addrl_Frame (Stmt, Right); + else + Num := O_Free; + end if; + case Reg is + when R_Sib => + Set_Expr_Reg (Stmt, R_B_Off); + return Stmt; + when R_Irm + | R_Ir => + if Right /= O_Enode_Null then + Free_Insn_Regs (Right); + end if; + Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum)); + Link_Stmt (Stmt); + return Stmt; + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + when OE_Addrg => + case Reg is + when R_Sib + | R_Irm + | R_Ir => + Set_Expr_Reg (Stmt, R_Imm); + return Stmt; + when R_Any32 + | Regs_R32 => + Set_Expr_Reg (Stmt, Reg); + Link_Stmt (Stmt); + return Stmt; + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + when OE_Indir => + Left := Get_Expr_Operand (Stmt); + case Reg is + when R_Irm + | R_Rm => + Left := Gen_Insn (Left, R_Sib, Pnum); + Set_Expr_Reg (Stmt, R_Mem); + Set_Expr_Operand (Stmt, Left); + when R_Ir + | R_Sib + | R_I_Off => + Num := Get_Insn_Num; + Left := Gen_Insn (Left, R_Sib, Num); + Reg1 := Get_Reg_Any (Stmt); + if Reg1 = R_Any64 then + Reg1 := Alloc_Reg (Reg1, Stmt, Pnum); + Free_Insn_Regs (Left); + else + Free_Insn_Regs (Left); + Reg1 := Alloc_Reg (Reg1, Stmt, Pnum); + end if; + Set_Expr_Reg (Stmt, Reg1); + Set_Expr_Operand (Stmt, Left); + Link_Stmt (Stmt); + when Regs_R32 + | R_Any32 + | R_Any8 + | Regs_Fp => + Num := Get_Insn_Num; + Left := Gen_Insn (Left, R_Sib, Num); + Free_Insn_Regs (Left); + Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); + Set_Expr_Operand (Stmt, Left); + Link_Stmt (Stmt); + when Regs_R64 + | R_Any64 => + -- Avoid overwritting: + -- Eg: axdx = indir (ax) + -- axdx = indir (ax+dx) + Num := Get_Insn_Num; + Left := Gen_Insn (Left, R_Sib, Num); + Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); + Left := Reload (Left, R_Sib, Num); + Free_Insn_Regs (Left); + Set_Expr_Operand (Stmt, Left); + Link_Stmt (Stmt); + when R_Any_Cc => + Num := Get_Insn_Num; + Left := Gen_Insn (Left, R_Sib, Num); + -- Generate a cmp $1, XX + Set_Expr_Reg (Stmt, R_Eq); + Set_Expr_Operand (Stmt, Left); + Free_Insn_Regs (Left); + Link_Stmt (Stmt); + Alloc_Cc (Stmt, Pnum); + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + return Stmt; + when OE_Conv_Ptr => + -- Delete nops. + return Gen_Insn (Get_Expr_Operand (Stmt), Reg, Pnum); + when OE_Const => + case Get_Expr_Mode (Stmt) is + when Mode_U8 .. Mode_U32 + | Mode_I8 .. Mode_I32 + | Mode_P32 + | Mode_B2 => + case Reg is + when R_Imm + | Regs_Imm32 => + Set_Expr_Reg (Stmt, R_Imm); + when Regs_R32 + | R_Any32 + | R_Any8 => + Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); + Link_Stmt (Stmt); + when R_Rm => + Set_Expr_Reg + (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum)); + Link_Stmt (Stmt); + when R_Any_Cc => + Num := Get_Insn_Num; + Set_Expr_Reg + (Stmt, Alloc_Reg (R_Any8, Stmt, Num)); + Link_Stmt (Stmt); + Free_Insn_Regs (Stmt); + Right := Insert_Move (Stmt, R_Ne); + Alloc_Cc (Right, Pnum); + return Right; + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + when Mode_F32 + | Mode_F64 => + case Reg is + when R_Ir + | R_Irm + | R_Rm + | R_St0 => + Num := Get_Insn_Num; + Set_Expr_Reg + (Stmt, Alloc_Reg (R_St0, Stmt, Num)); + Link_Stmt (Stmt); + when others => + raise Program_Error; + end case; + when Mode_U64 + | Mode_I64 => + case Reg is + when R_Irm + | R_Ir + | R_Rm => + Set_Expr_Reg (Stmt, R_Imm); + when R_Mem => + Set_Expr_Reg (Stmt, R_Mem); + when Regs_R64 + | R_Any64 => + Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); + Link_Stmt (Stmt); + when others => + raise Program_Error; + end case; + when others => + raise Program_Error; + end case; + return Stmt; + when OE_Alloca => + -- Roughly speaking, emited code is: (MASK is a constant). + -- VAL := (VAL + MASK) & ~MASK + -- SP := SP - VAL + -- res <- SP + Left := Get_Expr_Operand (Stmt); + case Reg is + when R_Ir + | R_Irm + | R_Any32 => + Num := Get_Insn_Num; + Left := Gen_Insn (Left, R_Any32, Num); + Set_Expr_Operand (Stmt, Left); + Link_Stmt (Left); + Free_Insn_Regs (Left); + Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum)); + Link_Stmt (Stmt); + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + return Stmt; + + when OE_Kind_Cmp => + -- Return LEFT cmp RIGHT, ie compute RIGHT - LEFT + Num := Get_Insn_Num; + Left := Get_Expr_Left (Stmt); + Reg_L := Get_Reg_Any (Left); + Left := Gen_Insn (Left, Reg_L, Num); + + Right := Get_Expr_Right (Stmt); + case Get_Expr_Mode (Right) is + when Mode_F32 + | Mode_F64 => + Reg1 := R_St0; + when others => + Reg1 := R_Irm; + end case; + Right := Gen_Insn (Right, Reg1, Num); + + -- FIXME: what about if right was spilled out of FP regs ? + -- (it is reloaded in reverse). + Left := Reload (Left, Reg_L, Num); + + Set_Expr_Right (Stmt, Right); + Set_Expr_Left (Stmt, Left); + + Link_Stmt (Stmt); + + Reg_Res := Ekind_To_Cc (Stmt, Get_Expr_Mode (Left)); + case Get_Expr_Mode (Left) is + when Mode_F32 + | Mode_F64 => + Reg_Res := Reverse_Cc (Reg_Res); + when Mode_I64 => + -- I64 is a little bit special... + Reg_Res := Get_R64_High (Get_Expr_Reg (Left)); + if Reg_Res not in Regs_R8 then + Reg_Res := R_Nil; + for I in Regs_R8 loop + if Regs (I).Num = O_Free then + Reg_Res := I; + exit; + end if; + end loop; + if Reg_Res = R_Nil then + -- FIXME: to be handled. + -- Can this happen ? + raise Program_Error; + end if; + end if; + + Free_Insn_Regs (Left); + Free_Insn_Regs (Right); + + Set_Expr_Reg (Stmt, Reg_Res); + case Reg is + when R_Any_Cc => + Right := Insert_Move (Stmt, R_Ne); + Alloc_Cc (Right, Pnum); + return Right; + when R_Any8 + | Regs_R8 + | R_Irm + | R_Ir + | R_Rm => + Reg_Res := Alloc_Reg (Reg_Res, Stmt, Pnum); + return Stmt; + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + when others => + null; + end case; + Set_Expr_Reg (Stmt, Reg_Res); + + Free_Insn_Regs (Left); + Free_Insn_Regs (Right); + + case Reg is + when R_Any_Cc => + Alloc_Cc (Stmt, Pnum); + return Stmt; + when R_Any8 + | Regs_R8 => + Reg_Res := Alloc_Reg (Reg, Stmt, Pnum); + return Insert_Move (Stmt, Reg_Res); + when R_Irm + | R_Ir + | R_Rm => + Reg_Res := Alloc_Reg (R_Any8, Stmt, Pnum); + return Insert_Move (Stmt, Reg_Res); + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + when OE_Add => + declare + R_L : O_Reg; + R_R : O_Reg; + begin + Left := Gen_Insn (Get_Expr_Left (Stmt), R_Sib, Pnum); + Right := Gen_Insn (Get_Expr_Right (Stmt), R_Sib, Pnum); + Left := Reload (Left, R_Sib, Pnum); + Set_Expr_Right (Stmt, Right); + Set_Expr_Left (Stmt, Left); + R_L := Get_Expr_Reg (Left); + R_R := Get_Expr_Reg (Right); + -- Results can be: Reg, R_B_Off, R_Sib, R_Imm, R_B_I + case R_L is + when R_Any32 + | Regs_R32 => + case R_R is + when R_Imm => + Set_Expr_Reg (Stmt, R_B_Off); + when R_B_Off + | R_I + | R_I_Off => + Set_Expr_Reg (Stmt, R_Sib); + when R_Any32 + | Regs_R32 => + Set_Expr_Reg (Stmt, R_B_I); + when others => + Error_Gen_Insn (Stmt, R_R); + end case; + when R_Imm => + case R_R is + when R_Imm => + Set_Expr_Reg (Stmt, R_Imm); + when R_Any32 + | Regs_R32 + | R_B_Off => + Set_Expr_Reg (Stmt, R_B_Off); + when R_I + | R_I_Off => + Set_Expr_Reg (Stmt, R_I_Off); + when others => + Error_Gen_Insn (Stmt, R_R); + end case; + when R_B_Off => + case R_R is + when R_Imm => + Set_Expr_Reg (Stmt, R_B_Off); + when R_Any32 + | Regs_R32 + | R_I => + Set_Expr_Reg (Stmt, R_Sib); + when others => + Error_Gen_Insn (Stmt, R_R); + end case; + when R_I_Off => + case R_R is + when R_Imm => + Set_Expr_Reg (Stmt, R_I_Off); + when R_Any32 + | Regs_R32 => + Set_Expr_Reg (Stmt, R_Sib); + when others => + Error_Gen_Insn (Stmt, R_R); + end case; + when R_I => + case R_R is + when R_Imm + | Regs_R32 + | R_B_Off => + Set_Expr_Reg (Stmt, R_Sib); + when others => + Error_Gen_Insn (Stmt, R_R); + end case; + when R_Sib + | R_B_I => + if R_R = R_Imm then + Set_Expr_Reg (Stmt, R_Sib); + else + Num := Get_Insn_Num; + Free_Insn_Regs (Left); + Set_Expr_Reg (Left, Alloc_Reg (R_Any32, Left, Num)); + Link_Stmt (Left); + case R_R is + when R_Any32 + | Regs_R32 + | R_I => + Set_Expr_Reg (Stmt, R_B_I); + when others => + Error_Gen_Insn (Stmt, R_R); + end case; + end if; + when others => + Error_Gen_Insn (Stmt, R_L); + end case; + + case Reg is + when R_Sib => + null; + when R_Ir + | R_Irm => + if Get_Expr_Reg (Stmt) /= R_Imm then + Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum)); + Free_Insn_Regs (Left); + Free_Insn_Regs (Right); + Link_Stmt (Stmt); + end if; + when R_Any32 + | Regs_R32 => + Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); + Link_Stmt (Stmt); + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + end; + return Stmt; + when OE_Mul => + Num := Get_Insn_Num; + Left := Gen_Insn (Get_Expr_Left (Stmt), R_Ax, Num); + Set_Expr_Left (Stmt, Left); + + Right := Gen_Insn (Get_Expr_Right (Stmt), R_Any32, Num); + if Get_Expr_Kind (Right) /= OE_Const then + raise Program_Error; + end if; + Set_Expr_Right (Stmt, Right); + + Free_Insn_Regs (Left); + Free_Insn_Regs (Right); + Clobber_R32 (R_Dx); + Set_Expr_Reg (Stmt, Alloc_Reg (R_Ax, Stmt, Pnum)); + case Reg is + when R_Sib + | R_B_Off => + null; + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + Link_Stmt (Stmt); + return Stmt; + when OE_Shl => + Num := Get_Insn_Num; + Right := Get_Expr_Right (Stmt); + if Get_Expr_Kind (Right) /= OE_Const then + Right := Gen_Insn (Right, R_Cx, Num); + else + Right := Gen_Insn (Right, R_Imm, Num); + end if; + Left := Get_Expr_Left (Stmt); + Reg1 := Get_Reg_Any (Stmt); + Left := Gen_Insn (Left, Reg1, Pnum); + if Get_Expr_Kind (Right) /= OE_Const then + Right := Reload (Right, R_Cx, Num); + end if; + Left := Reload (Left, Reg1, Pnum); + Set_Expr_Left (Stmt, Left); + Set_Expr_Right (Stmt, Right); + if Reg = R_Sib + and then Get_Expr_Kind (Right) = OE_Const + and then Get_Expr_Low (Right) in 0 .. 3 + then + Set_Expr_Reg (Stmt, R_I); + else + Link_Stmt (Stmt); + Set_Expr_Reg (Stmt, Get_Expr_Reg (Left)); + Free_Insn_Regs (Right); + end if; + return Stmt; + + when OE_Add_Ov + | OE_Sub_Ov + | OE_And + | OE_Xor + | OE_Or => + -- Accepted is: R with IMM or R/M + Num := Get_Insn_Num; + Right := Get_Expr_Right (Stmt); + Left := Get_Expr_Left (Stmt); + case Reg is + when R_Irm + | R_Rm + | R_Ir + | R_Sib => + Right := Gen_Insn (Right, R_Irm, Num); + Reg1 := Get_Reg_Any (Stmt); + Left := Gen_Insn (Left, Reg1, Num); + Right := Reload (Right, R_Irm, Num); + Left := Reload (Left, Reg1, Num); + Reg_Res := Get_Expr_Reg (Left); + when R_Any_Cc => + Right := Gen_Insn (Right, R_Irm, Num); + Left := Gen_Insn (Left, R_Any8, Num); + Reg_Res := R_Ne; + Alloc_Cc (Stmt, Num); + Free_Insn_Regs (Left); + when R_Any32 + | Regs_R32 + | R_Any8 + | R_Any64 + | Regs_R64 + | Regs_Fp => + Right := Gen_Insn (Right, R_Irm, Num); + Left := Gen_Insn (Left, Reg, Num); + Right := Reload (Right, R_Irm, Num); + Left := Reload (Left, Reg, Num); + Reg_Res := Get_Expr_Reg (Left); + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + Set_Expr_Right (Stmt, Right); + Set_Expr_Left (Stmt, Left); + Set_Expr_Reg (Stmt, Reg_Res); + Renum_Reg (Reg_Res, Stmt, Pnum); + Link_Stmt (Stmt); + Free_Insn_Regs (Right); + return Stmt; + + when OE_Mod + | OE_Rem + | OE_Mul_Ov + | OE_Div_Ov => + declare + Mode : Mode_Type; + begin + Num := Get_Insn_Num; + Mode := Get_Expr_Mode (Stmt); + Left := Get_Expr_Left (Stmt); + Right := Get_Expr_Right (Stmt); + case Mode is + when Mode_I32 + | Mode_U32 + | Mode_I16 + | Mode_U16 => + Left := Gen_Insn (Left, R_Ax, Num); + Right := Gen_Insn (Right, R_Rm, Num); + Left := Reload (Left, R_Ax, Num); + case Kind is + when OE_Div_Ov + | OE_Rem + | OE_Mod => + -- Be sure EDX is free. + Reg_Res := Alloc_Reg (R_Dx, Stmt, Pnum); + when others => + Reg_Res := R_Nil; + end case; + Right := Reload (Right, R_Rm, Num); + Set_Expr_Right (Stmt, Right); + Set_Expr_Left (Stmt, Left); + Free_Insn_Regs (Left); + Free_Insn_Regs (Right); + if Reg_Res /= R_Nil then + Free_R32 (Reg_Res); + end if; + if Kind = OE_Div_Ov or Kind = OE_Mul_Ov then + Reg_Res := R_Ax; + else + Reg_Res := R_Dx; + end if; + Set_Expr_Reg (Stmt, Alloc_Reg (Reg_Res, Stmt, Pnum)); + Link_Stmt (Stmt); + return Stmt; + when Mode_U64 + | Mode_I64 => + Insert_Arg (Gen_Insn (Right, R_Irm, Num)); + Insert_Arg (Gen_Insn (Left, R_Irm, Num)); + return Insert_Intrinsic (Stmt, R_Edx_Eax, Pnum); + when Mode_F32 + | Mode_F64 => + Left := Gen_Insn (Left, R_St0, Num); + Right := Gen_Insn (Right, R_Rm, Num); + Set_Expr_Left (Stmt, Left); + Set_Expr_Right (Stmt, Right); + Free_Insn_Regs (Right); + Free_Insn_Regs (Left); + Set_Expr_Reg (Stmt, Alloc_Reg (R_St0, Stmt, Pnum)); + Link_Stmt (Stmt); + return Stmt; + when others => + Error_Gen_Insn (Stmt, Mode); + end case; + end; + + when OE_Not + | OE_Abs_Ov + | OE_Neg_Ov => + Left := Get_Expr_Operand (Stmt); + case Reg is + when R_Any32 + | Regs_R32 + | R_Any64 + | Regs_R64 + | R_Any8 + | R_St0 => + Reg_Res := Reg; + when R_Any_Cc => + if Kind /= OE_Not then + raise Program_Error; + end if; + Left := Gen_Insn (Left, R_Any_Cc, Pnum); + Set_Expr_Operand (Stmt, Left); + Set_Expr_Reg (Stmt, Inverse_Cc (Get_Expr_Reg (Left))); + return Stmt; + when R_Irm + | R_Rm + | R_Ir => + Reg_Res := Get_Reg_Any (Get_Expr_Mode (Left)); + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + Left := Gen_Insn (Left, Reg_Res, Pnum); + Set_Expr_Operand (Stmt, Left); + Set_Expr_Reg (Stmt, Get_Expr_Reg (Left)); + Link_Stmt (Stmt); + return Stmt; + when OE_Conv => + declare + O_Mode : Mode_Type; + R_Mode : Mode_Type; + begin + Left := Get_Expr_Operand (Stmt); + O_Mode := Get_Expr_Mode (Left); + R_Mode := Get_Expr_Mode (Stmt); + -- Simple case: no conversion. + -- FIXME: should be handled by EXPR and convert to NOP. + if Get_Expr_Mode (Left) = Get_Expr_Mode (Stmt) then + -- A no-op. + return Gen_Insn (Left, Reg, Pnum); + end if; + case R_Mode is + when Mode_B2 => + case O_Mode is + when Mode_U32 + | Mode_I32 => + -- Detect for bound. + null; + when others => + Error_Gen_Insn (Stmt, O_Mode); + end case; + when Mode_U8 => + case O_Mode is + when Mode_U16 + | Mode_U32 + | Mode_I32 => + -- Detect for bound. + null; + when others => + Error_Gen_Insn (Stmt, O_Mode); + end case; + when Mode_U32 => + case O_Mode is + when Mode_I32 => + -- Detect for bound. + null; + when Mode_B2 + | Mode_U8 + | Mode_U16 => + -- Zero extend. + null; + when others => + Error_Gen_Insn (Stmt, O_Mode); + end case; + when Mode_I32 => + case O_Mode is + when Mode_U8 + | Mode_I8 + | Mode_B2 + | Mode_U16 + | Mode_U32 => + -- Zero extend + -- Detect for bound (U32). + null; + when Mode_I64 => + -- Detect for bound (U32) + Num := Get_Insn_Num; + Left := Gen_Insn (Left, R_Edx_Eax, Num); + Free_Insn_Regs (Left); + Set_Expr_Operand (Stmt, Left); + case Reg is + when R_Ax + | R_Any32 + | R_Rm + | R_Irm + | R_Ir => + Set_Expr_Reg + (Stmt, Alloc_Reg (R_Ax, Stmt, Num)); + when others => + raise Program_Error; + end case; + Insert_Reg (Mode_U32); + Link_Stmt (Stmt); + return Stmt; + when Mode_F64 + | Mode_F32 => + return Gen_Conv_From_Fp_Insn (Stmt, Reg, Pnum); + when others => + Error_Gen_Insn (Stmt, O_Mode); + end case; + when Mode_I64 => + case O_Mode is + when Mode_I32 => + -- Sign extend. + Num := Get_Insn_Num; + Left := Gen_Insn (Left, R_Ax, Num); + Set_Expr_Operand (Stmt, Left); + Free_Insn_Regs (Left); + case Reg is + when R_Edx_Eax + | R_Any64 + | R_Rm + | R_Irm + | R_Ir => + Set_Expr_Reg + (Stmt, Alloc_Reg (R_Edx_Eax, Stmt, Pnum)); + when others => + raise Program_Error; + end case; + Link_Stmt (Stmt); + return Stmt; + when Mode_F64 + | Mode_F32 => + return Gen_Conv_From_Fp_Insn (Stmt, Reg, Pnum); + when others => + Error_Gen_Insn (Stmt, O_Mode); + end case; + when Mode_F64 => + case O_Mode is + when Mode_I32 + | Mode_I64 => + null; + when others => + Error_Gen_Insn (Stmt, O_Mode); + end case; + when others => + Error_Gen_Insn (Stmt, O_Mode); + end case; + Left := Gen_Insn (Left, R_Rm, Pnum); + Set_Expr_Operand (Stmt, Left); + case Reg is + when R_Irm + | R_Rm + | R_Ir + | R_Any32 + | Regs_R32 + | R_Any64 + | R_Any8 + | Regs_R64 + | Regs_Fp => + Free_Insn_Regs (Left); + Set_Expr_Reg + (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum)); + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + Link_Stmt (Stmt); + return Stmt; + end; + when OE_Arg => + if Reg /= R_None then + raise Program_Error; + end if; + Left := Get_Arg_Link (Stmt); + if Left /= O_Enode_Null then + -- Previous argument. + Left := Gen_Insn (Left, R_None, Pnum); + end if; + Left := Get_Expr_Operand (Stmt); + case Get_Expr_Mode (Left) is + when Mode_F32 .. Mode_F64 => + -- fstp instruction. + Reg_Res := R_St0; + when others => + -- Push instruction. + Reg_Res := R_Irm; + end case; + Left := Gen_Insn (Left, Reg_Res, Pnum); + Set_Expr_Operand (Stmt, Left); + Link_Stmt (Stmt); + Free_Insn_Regs (Left); + return Stmt; + when OE_Call => + Left := Get_Arg_Link (Stmt); + if Left /= O_Enode_Null then + -- Generate code for arguments. + Left := Gen_Insn (Left, R_None, Pnum); + end if; + + -- Clobber registers. + Clobber_R32 (R_Ax); + Clobber_R32 (R_Dx); + Clobber_R32 (R_Cx); + -- FIXME: fp regs. + + Reg_Res := Get_Call_Register (Get_Expr_Mode (Stmt)); + Set_Expr_Reg (Stmt, Reg_Res); + Link_Stmt (Stmt); + + case Reg is + when R_Any32 + | R_Any64 + | R_Any8 + | R_Irm + | R_Rm + | R_Ir + | R_Sib + | R_Ax + | R_St0 + | R_Edx_Eax => + Reg_Res := Alloc_Reg (Reg_Res, Stmt, Pnum); + return Stmt; + when R_Any_Cc => + -- Move to register. + -- (use the 'test' instruction). + Alloc_Cc (Stmt, Pnum); + return Insert_Move (Stmt, R_Ne); + when R_None => + if Reg_Res /= R_None then + raise Program_Error; + end if; + return Stmt; + when others => + Error_Gen_Insn (Stmt, Reg); + end case; + when OE_Case_Expr => + Left := Get_Expr_Operand (Stmt); + Set_Expr_Reg (Stmt, Alloc_Reg (Get_Expr_Reg (Left), Stmt, Pnum)); + return Stmt; + when OE_Get_Stack => + Set_Expr_Reg (Stmt, R_Sp); + return Stmt; + when OE_Get_Frame => + Set_Expr_Reg (Stmt, R_Bp); + return Stmt; + when others => + Ada.Text_IO.Put_Line + ("gen_insn: unhandled enode " & OE_Kind'Image (Kind)); + raise Program_Error; + end case; + end Gen_Insn; + + procedure Assert_Free_Regs (Stmt : O_Enode) is + begin + for I in Regs_R32 loop + if Regs (I).Num /= O_Free then + Error_Reg ("gen_insn_stmt: reg is not free", Stmt, I); + end if; + end loop; + for I in Fp_Stack_Type loop + if Fp_Regs (I).Stmt /= O_Enode_Null then + Error_Reg ("gen_insn_stmt: reg is not free", Stmt, R_St0); + end if; + end loop; + end Assert_Free_Regs; + + procedure Gen_Insn_Stmt (Stmt : O_Enode) + is + Kind : OE_Kind; + + Left : O_Enode; + Right : O_Enode; + P_Reg : O_Reg; + Num : O_Inum; + + Prev_Stack_Offset : Uns32; + begin + Insn_Num := O_Iroot; + Num := Get_Insn_Num; + Prev_Stack_Offset := Stack_Offset; + + Kind := Get_Expr_Kind (Stmt); + case Kind is + when OE_Asgn => + Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Ir, Num); + Right := Gen_Insn (Get_Assign_Target (Stmt), R_Sib, Num); + Left := Reload (Left, R_Ir, Num); + --Right := Reload (Right, R_Sib, Num); + Set_Expr_Operand (Stmt, Left); + Set_Assign_Target (Stmt, Right); + Link_Stmt (Stmt); + Free_Insn_Regs (Left); + Free_Insn_Regs (Right); + when OE_Set_Stack => + Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Rm, Num); + Set_Expr_Operand (Stmt, Left); + Set_Expr_Reg (Stmt, R_Sp); + Link_Stmt (Stmt); + when OE_Jump_F + | OE_Jump_T => + Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Any_Cc, Num); + Set_Expr_Operand (Stmt, Left); + Link_Stmt (Stmt); + Free_Cc; + when OE_Beg => + declare + Block_Decl : O_Dnode; + begin + Cur_Block := Stmt; + Block_Decl := Get_Block_Decls (Cur_Block); + Set_Block_Max_Stack (Block_Decl, Stack_Offset); + Expand_Decls (Block_Decl); + end; + Link_Stmt (Stmt); + when OE_End => + Swap_Stack_Offset (Get_Block_Decls (Cur_Block)); + Cur_Block := Get_Block_Parent (Cur_Block); + Link_Stmt (Stmt); + when OE_Jump + | OE_Label => + Link_Stmt (Stmt); + when OE_Leave => + Link_Stmt (Stmt); + when OE_Call => + Left := Get_Arg_Link (Stmt); + if Left /= O_Enode_Null then + -- Generate code for arguments. + Left := Gen_Insn (Left, R_None, Num); + end if; + Set_Expr_Reg (Stmt, R_None); + Link_Stmt (Stmt); + when OE_Ret => + Left := Get_Expr_Operand (Stmt); + P_Reg := Get_Call_Register (Get_Expr_Mode (Stmt)); + Left := Gen_Insn (Left, P_Reg, Num); + Set_Expr_Operand (Stmt, Left); + Link_Stmt (Stmt); + Free_Insn_Regs (Left); + when OE_Case => + Left := Gen_Insn (Get_Expr_Operand (Stmt), + Get_Reg_Any (Get_Expr_Mode (Stmt)), + Num); + Set_Expr_Operand (Stmt, Left); + Set_Expr_Reg (Stmt, Get_Expr_Reg (Left)); + Link_Stmt (Stmt); + Free_Insn_Regs (Left); + when OE_Line => + Set_Expr_Reg (Stmt, R_None); + Link_Stmt (Stmt); + when OE_BB => + -- Keep BB. + Link_Stmt (Stmt); + when others => + Ada.Text_IO.Put_Line + ("gen_insn_stmt: unhandled enode " & OE_Kind'Image (Kind)); + raise Program_Error; + end case; + + -- Free any spill stack slots. + case Kind is + when OE_Beg + | OE_End => + null; + when others => + Stack_Offset := Prev_Stack_Offset; + end case; + + -- Check all registers are free. + if Debug.Flag_Debug_Assert then + Assert_Free_Regs (Stmt); + end if; + end Gen_Insn_Stmt; + + procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc) + is + First : O_Enode; + Last : O_Enode; + Stmt : O_Enode; + N_Stmt : O_Enode; + begin + if Debug.Flag_Debug_Insn then + declare + Inter : O_Dnode; + begin + Disp_Decl (1, Subprg.D_Decl); + Inter := Get_Subprg_Interfaces (Subprg.D_Decl); + while Inter /= O_Dnode_Null loop + Disp_Decl (2, Inter); + Inter := Get_Interface_Chain (Inter); + end loop; + end; + end if; + + for I in Regs_R32 loop + Regs (I).Used := False; + end loop; + + Stack_Max := 0; + Stack_Offset := 0; + First := Subprg.E_Entry; + Expand_Decls (Subprg.D_Body + 1); + Last := Get_Entry_Leave (First); + Abi.Last_Link := First; + + -- Generate instructions. + -- Skip OE_Entry. + Stmt := Get_Stmt_Link (First); + loop + N_Stmt := Get_Stmt_Link (Stmt); + Gen_Insn_Stmt (Stmt); + exit when Get_Expr_Kind (Stmt) = OE_Leave; + Stmt := N_Stmt; + end loop; + Subprg.Stack_Max := Stack_Max; + end Gen_Subprg_Insns; + +end Ortho_Code.X86.Insns; diff --git a/ortho/mcode/ortho_code-x86-insns.ads b/ortho/mcode/ortho_code-x86-insns.ads new file mode 100644 index 0000000..9411737 --- /dev/null +++ b/ortho/mcode/ortho_code-x86-insns.ads @@ -0,0 +1,25 @@ +-- Mcode back-end for ortho - mcode to X86 instructions. +-- 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. +package Ortho_Code.X86.Insns is + function Reg_Used (Reg : Regs_R32) return Boolean; + + -- Split enodes of SUBPRG into instructions. + procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc); + +end Ortho_Code.X86.Insns; + diff --git a/ortho/mcode/ortho_code-x86.adb b/ortho/mcode/ortho_code-x86.adb new file mode 100644 index 0000000..175dd7e --- /dev/null +++ b/ortho/mcode/ortho_code-x86.adb @@ -0,0 +1,109 @@ +-- Mcode back-end for ortho - X86 common definitions. +-- 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. +package body Ortho_Code.X86 is + function Inverse_Cc (R : O_Reg) return O_Reg is + begin + case R is + when R_Ult => + return R_Uge; + when R_Uge => + return R_Ult; + when R_Eq => + return R_Ne; + when R_Ne => + return R_Eq; + when R_Ule => + return R_Ugt; + when R_Ugt => + return R_Ule; + when R_Slt => + return R_Sge; + when R_Sge => + return R_Slt; + when R_Sle => + return R_Sgt; + when R_Sgt => + return R_Sle; + when others => + raise Program_Error; + end case; + end Inverse_Cc; + + function Get_R64_High (Reg : Regs_R64) return Regs_R32 is + begin + case Reg is + when R_Edx_Eax => + return R_Dx; + when R_Ebx_Ecx => + return R_Bx; + when R_Esi_Edi => + return R_Si; + end case; + end Get_R64_High; + + function Get_R64_Low (Reg : Regs_R64) return Regs_R32 is + begin + case Reg is + when R_Edx_Eax => + return R_Ax; + when R_Ebx_Ecx => + return R_Cx; + when R_Esi_Edi => + return R_Di; + end case; + end Get_R64_Low; + + function Ekind_Unsigned_To_Cc (Kind : OE_Kind_Cmp) return O_Reg is + begin + case Kind is + when OE_Eq => + return R_Eq; + when OE_Neq => + return R_Ne; + when OE_Lt => + return R_Ult; + when OE_Le => + return R_Ule; + when OE_Gt => + return R_Ugt; + when OE_Ge => + return R_Uge; + end case; + end Ekind_Unsigned_To_Cc; + + function Ekind_Signed_To_Cc (Kind : OE_Kind_Cmp) return O_Reg is + begin + case Kind is + when OE_Eq => + return R_Eq; + when OE_Neq => + return R_Ne; + when OE_Lt => + return R_Slt; + when OE_Le => + return R_Sle; + when OE_Gt => + return R_Sgt; + when OE_Ge => + return R_Sge; + end case; + end Ekind_Signed_To_Cc; + +end Ortho_Code.X86; + + diff --git a/ortho/mcode/ortho_code-x86.ads b/ortho/mcode/ortho_code-x86.ads new file mode 100644 index 0000000..235f1c1 --- /dev/null +++ b/ortho/mcode/ortho_code-x86.ads @@ -0,0 +1,137 @@ +-- Mcode back-end for ortho - X86 common definitions. +-- 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 Ortho_Code.Exprs; use Ortho_Code.Exprs; + +package Ortho_Code.X86 is + -- Registers. + R_Nil : constant O_Reg := 0; + + -- Not a value. Used for statements. + R_None : constant O_Reg := 1; + + -- Memory. + R_Mem : constant O_Reg := 2; + + -- Spilled out. + R_Spill : constant O_Reg := 3; + + -- Register or memory. + -- THis can only be requested. + R_Rm : constant O_Reg := 48; + + -- Immediat + R_Imm : constant O_Reg := 49; + + -- Immediat, register or memory. + -- This can be requested. + R_Irm : constant O_Reg := 50; + + -- Immediat or register. + -- This can be requested. + R_Ir : constant O_Reg := 51; + + -- BASE + OFFSET + R_B_Off : constant O_Reg := 52; + + -- BASE+INDEX*SCALE+OFFSET + -- This can be requested. + R_Sib : constant O_Reg := 53; + + -- INDEX*SCALE + OFFSET + -- This can be requested. + R_I_Off : constant O_Reg := 54; + + -- BASE + INDEX*SCALE + R_B_I : constant O_Reg := 55; + + -- INDEX*SCALE + R_I : constant O_Reg := 56; + + subtype Regs_Imm32 is O_Reg range R_Irm .. R_I_Off; + + R_Any8 : constant O_Reg := 6; + R_Any32 : constant O_Reg := 7; + R_Ax : constant O_Reg := 8; + R_Cx : constant O_Reg := 9; + R_Dx : constant O_Reg := 10; + R_Bx : constant O_Reg := 11; + R_Sp : constant O_Reg := 12; + R_Bp : constant O_Reg := 13; + R_Si : constant O_Reg := 14; + R_Di : constant O_Reg := 15; + + subtype Regs_R8 is O_Reg range R_Ax .. R_Bx; + subtype Regs_R32 is O_Reg range R_Ax .. R_Di; + + R_St0 : constant O_Reg := 16; + R_St1 : constant O_Reg := 17; + R_St2 : constant O_Reg := 18; + R_St3 : constant O_Reg := 19; + R_St4 : constant O_Reg := 20; + R_St5 : constant O_Reg := 21; + R_St6 : constant O_Reg := 22; + R_St7 : constant O_Reg := 23; + --R_Any_Fp : constant O_Reg := 24; + + subtype Regs_Fp is O_Reg range R_St0 .. R_St7; + + -- Any condition register. + R_Any_Cc : constant O_Reg := 32; + R_Ov : constant O_Reg := 32; + R_Ult : constant O_Reg := 34; + R_Uge : constant O_Reg := 35; + R_Eq : constant O_Reg := 36; + R_Ne : constant O_Reg := 37; + R_Ule : constant O_Reg := 38; + R_Ugt : constant O_Reg := 39; + R_Slt : constant O_Reg := 44; + R_Sge : constant O_Reg := 45; + R_Sle : constant O_Reg := 46; + R_Sgt : constant O_Reg := 47; + + subtype Regs_Cc is O_Reg range R_Ov .. R_Sgt; + + R_Edx_Eax : constant O_Reg := 64; + R_Ebx_Ecx : constant O_Reg := 65; + R_Esi_Edi : constant O_Reg := 66; + R_Any64 : constant O_Reg := 67; + + subtype Regs_R64 is O_Reg range R_Edx_Eax .. R_Esi_Edi; + + function Get_R64_High (Reg : Regs_R64) return Regs_R32; + function Get_R64_Low (Reg : Regs_R64) return Regs_R32; + + function Inverse_Cc (R : O_Reg) return O_Reg; + + -- Intrinsic subprograms. + Intrinsic_Mul_Ov_U64 : constant Int32 := 1; + Intrinsic_Div_Ov_U64 : constant Int32 := 2; + Intrinsic_Mod_Ov_U64 : constant Int32 := 3; + Intrinsic_Mul_Ov_I64 : constant Int32 := 4; + Intrinsic_Div_Ov_I64 : constant Int32 := 5; + Intrinsic_Mod_Ov_I64 : constant Int32 := 6; + Intrinsic_Rem_Ov_I64 : constant Int32 := 7; + + subtype Intrinsics_X86 is Int32 + range Intrinsic_Mul_Ov_U64 .. Intrinsic_Rem_Ov_I64; + + -- Convert a KIND to a reg. + function Ekind_Unsigned_To_Cc (Kind : OE_Kind_Cmp) return O_Reg; + function Ekind_Signed_To_Cc (Kind : OE_Kind_Cmp) return O_Reg; + +end Ortho_Code.X86; diff --git a/ortho/mcode/ortho_code.ads b/ortho/mcode/ortho_code.ads new file mode 100644 index 0000000..404c9be --- /dev/null +++ b/ortho/mcode/ortho_code.ads @@ -0,0 +1,147 @@ +-- Mcode back-end for ortho - common definitions. +-- 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 Ada.Unchecked_Conversion; + +package Ortho_Code is + type Int32 is range -(2 ** 31) .. (2 ** 31) - 1; + + type Uns32 is mod 2 ** 32; + + type Uns64 is mod 2 ** 64; + + function Shift_Right (L : Uns64; R : Natural) return Uns64; + function Shift_Right (L : Uns32; R : Natural) return Uns32; + pragma Import (Intrinsic, Shift_Right); + + function Shift_Left (L : Uns32; R : Natural) return Uns32; + pragma Import (Intrinsic, Shift_Left); + + type O_Tnode is new Int32; + for O_Tnode'Size use 32; + O_Tnode_Null : constant O_Tnode := 0; + O_Tnode_First : constant O_Tnode := 2; + + -- A generic pointer. + -- This is used by static chains. + O_Tnode_Ptr : constant O_Tnode := 2; + + type O_Cnode is new Int32; + for O_Cnode'Size use 32; + O_Cnode_Null : constant O_Cnode := 0; + + type O_Dnode is new Int32; + for O_Dnode'Size use 32; + O_Dnode_Null : constant O_Dnode := 0; + O_Dnode_First : constant O_Dnode := 2; + + type O_Enode is new Int32; + for O_Enode'Size use 32; + O_Enode_Null : constant O_Enode := 0; + O_Enode_Err : constant O_Enode := 1; + + type O_Fnode is new Int32; + for O_Fnode'Size use 32; + O_Fnode_Null : constant O_Fnode := 0; + + type O_Lnode is new Int32; + for O_Lnode'Size use 32; + O_Lnode_Null : constant O_Lnode := 0; + + type O_Ident is new Int32; + O_Ident_Nul : constant O_Ident := 0; + + function To_Int32 is new Ada.Unchecked_Conversion + (Source => Uns32, Target => Int32); + + function To_Uns32 is new Ada.Unchecked_Conversion + (Source => Int32, Target => Uns32); + + + -- Specifies the storage kind of a declaration. + -- O_STORAGE_EXTERNAL: + -- The declaration do not either reserve memory nor generate code, and + -- is imported either from an other file or from a later place in the + -- current file. + -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE: + -- The declaration reserves memory or generates code. + -- With O_STORAGE_PUBLIC, the declaration is exported outside of the + -- file while with O_STORAGE_PRIVATE, the declaration is local to the + -- file. + type O_Storage is (O_Storage_External, + O_Storage_Public, + O_Storage_Private, + O_Storage_Local); + + -- Depth of a declaration. + -- 0 for top-level, + -- 1 for declared in a top-level subprogram + type O_Depth is range 0 .. (2 ** 16) - 1; + O_Toplevel : constant O_Depth := 0; + + -- BE representation of a register. + type O_Reg is mod 256; + R_Nil : constant O_Reg := 0; + + type Mode_Type is (Mode_U8, Mode_U16, Mode_U32, Mode_U64, + Mode_I8, Mode_I16, Mode_I32, Mode_I64, + Mode_X1, Mode_Nil, Mode_F32, Mode_F64, + Mode_B2, Mode_Blk, Mode_P32, Mode_P64); + + subtype Mode_Uns is Mode_Type range Mode_U8 .. Mode_U64; + subtype Mode_Int is Mode_Type range Mode_I8 .. Mode_I64; + subtype Mode_Fp is Mode_Type range Mode_F32 .. Mode_F64; + -- Mode_Ptr : constant Mode_Type := Mode_P32; + + type ON_Op_Kind is + ( + -- Not an operation; invalid. + ON_Nil, + + -- Dyadic operations. + ON_Add_Ov, -- ON_Dyadic_Op_Kind + ON_Sub_Ov, -- ON_Dyadic_Op_Kind + ON_Mul_Ov, -- ON_Dyadic_Op_Kind + ON_Div_Ov, -- ON_Dyadic_Op_Kind + ON_Rem_Ov, -- ON_Dyadic_Op_Kind + ON_Mod_Ov, -- ON_Dyadic_Op_Kind + + -- Binary operations. + ON_And, -- ON_Dyadic_Op_Kind + ON_Or, -- ON_Dyadic_Op_Kind + ON_Xor, -- ON_Dyadic_Op_Kind + + -- Monadic operations. + ON_Not, -- ON_Monadic_Op_Kind + ON_Neg_Ov, -- ON_Monadic_Op_Kind + ON_Abs_Ov, -- ON_Monadic_Op_Kind + + -- Comparaisons + ON_Eq, -- ON_Compare_Op_Kind + ON_Neq, -- ON_Compare_Op_Kind + ON_Le, -- ON_Compare_Op_Kind + ON_Lt, -- ON_Compare_Op_Kind + ON_Ge, -- ON_Compare_Op_Kind + ON_Gt -- ON_Compare_Op_Kind + ); + + subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; + subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; + subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; + + Syntax_Error : exception; +end Ortho_Code; diff --git a/ortho/mcode/ortho_code_main.adb b/ortho/mcode/ortho_code_main.adb new file mode 100644 index 0000000..7744b88 --- /dev/null +++ b/ortho/mcode/ortho_code_main.adb @@ -0,0 +1,203 @@ +-- Mcode back-end for ortho - Main subprogram. +-- 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 Ada.Unchecked_Conversion; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Unchecked_Deallocation; +with Ada.Text_IO; use Ada.Text_IO; +with Binary_File; use Binary_File; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Ortho_Code.Debug; +with Ortho_Mcode; use Ortho_Mcode; +with Ortho_Front; use Ortho_Front; +with Ortho_Code.Flags; use Ortho_Code.Flags; +with Binary_File; +with Binary_File.Elf; +with Binary_File.Coff; +with Binary_File.Memory; +with Interfaces; + +procedure Ortho_Code_Main +is + Output : String_Acc := null; + type Format_Type is (Format_Coff, Format_Elf); + Format : Format_Type := Format_Elf; + Fd : File_Descriptor; + + First_File : Natural; + Opt : String_Acc; + Opt_Arg : String_Acc; + Filename : String_Acc; + Exec_Func : String_Acc; + Res : Natural; + I : Natural; + Argc : Natural; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => String_Acc, Object => String); +begin + First_File := Natural'Last; + Exec_Func := null; + + Ortho_Front.Init; + + Argc := Argument_Count; + I := 1; + while I <= Argc loop + declare + Arg : String := Argument (I); + begin + if Arg (1) = '-' then + if Arg'Length > 5 and then Arg (1 .. 5) = "--be-" then + Ortho_Code.Debug.Set_Be_Flag (Arg); + I := I + 1; + elsif Arg = "-o" then + if I = Argc then + Put_Line (Standard_Error, "error: missing filename to '-o'"); + return; + end if; + Output := new String'(Argument (I + 1)); + I := I + 2; + elsif Arg = "-quiet" then + -- Skip silently. + I := I + 1; + elsif Arg = "--exec" then + if I = Argc then + Put_Line (Standard_Error, + "error: missing function name to '--exec'"); + return; + end if; + Exec_Func := new String'(Argument (I + 1)); + I := I + 2; + elsif Arg = "-g" then + Flag_Debug := Debug_Dwarf; + I := I + 1; + elsif Arg = "-p" or Arg = "-pg" then + Flag_Profile := True; + I := I + 1; + else + -- This is really an argument. + Opt := new String'(Arg); + if I < Argument_Count then + Opt_Arg := new String'(Argument (I + 1)); + else + Opt_Arg := null; + end if; + Res := Ortho_Front.Decode_Option (Opt, Opt_Arg); + case Res is + when 0 => + Put_Line (Standard_Error, "unknown option '" & Arg & "'"); + return; + when 1 => + I := I + 1; + when 2 => + I := I + 2; + when others => + raise Program_Error; + end case; + Unchecked_Deallocation (Opt); + Unchecked_Deallocation (Opt_Arg); + end if; + else + First_File := I; + exit; + end if; + end; + end loop; + + Ortho_Mcode.Init; + + Set_Exit_Status (Failure); + + if First_File > Argument_Count then + begin + if not Parse (null) then + return; + end if; + exception + when others => + return; + end; + else + for I in First_File .. Argument_Count loop + Filename := new String'(Argument (First_File)); + begin + if not Parse (Filename) then + return; + end if; + exception + when others => + return; + end; + end loop; + end if; + + Ortho_Mcode.Finish; + + if Ortho_Code.Debug.Flag_Debug_Hli then + Set_Exit_Status (Success); + return; + end if; + + if Output /= null then + Fd := Create_File (Output.all, Binary); + if Fd /= Invalid_FD then + case Format is + when Format_Elf => + Binary_File.Elf.Write_Elf (Fd); + when Format_Coff => + Binary_File.Coff.Write_Coff (Fd); + end case; + Close (Fd); + end if; + elsif Exec_Func /= null then + declare + use Binary_File; + use Interfaces; + use Ada.Text_IO; + Sym : Symbol; + + type Func_Acc is access function return Integer; + function Conv is new Ada.Unchecked_Conversion + (Source => Unsigned_32, Target => Func_Acc); + F : Func_Acc; + V : Integer; + Err : Boolean; + begin + Binary_File.Memory.Write_Memory_Init; + Binary_File.Memory.Write_Memory_Relocate (Err); + if Err then + return; + end if; + Sym := Binary_File.Get_Symbol (Exec_Func.all); + if Sym = Null_Symbol then + Put_Line (Standard_Error, "no '" & Exec_Func.all & "' symbol"); + else + F := Conv (Get_Symbol_Vaddr (Sym)); + V := F.all; + Put_Line ("Result is " & Integer'Image (V)); + end if; + end; + end if; + + Set_Exit_Status (Success); +exception + when others => + Set_Exit_Status (2); + raise; +end Ortho_Code_Main; + + diff --git a/ortho/mcode/ortho_ident.adb b/ortho/mcode/ortho_ident.adb new file mode 100644 index 0000000..59c1276 --- /dev/null +++ b/ortho/mcode/ortho_ident.adb @@ -0,0 +1,111 @@ +-- Mcode back-end for ortho. +-- 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 Ada.Text_IO; +with GNAT.Table; + +package body Ortho_Ident is + package Ids is new GNAT.Table + (Table_Component_Type => Natural, + Table_Index_Type => O_Ident, + Table_Low_Bound => 2, + Table_Initial => 128, + Table_Increment => 100); + + package Strs is new GNAT.Table + (Table_Component_Type => Character, + Table_Index_Type => Natural, + Table_Low_Bound => 2, + Table_Initial => 128, + Table_Increment => 100); + + function Get_Identifier (Str : String) return O_Ident + is + Start : Natural; + begin + Start := Strs.Allocate (Str'Length); + for I in Str'Range loop + Strs.Table (Start + I - Str'First) := Str (I); + end loop; + Ids.Append (Start); + return Ids.Last; + end Get_Identifier; + + function Is_Equal (L, R : O_Ident) return Boolean + is + begin + return L = R; + end Is_Equal; + + function Get_String_Length (Id : O_Ident) return Natural + is + Start : Natural; + begin + Start := Ids.Table (Id); + if Id = Ids.Last then + return Strs.Last - Start + 1; + else + return Ids.Table (Id + 1) - Start; + end if; + end Get_String_Length; + + function Get_String (Id : O_Ident) return String + is + Res : String (1 .. Get_String_Length (Id)); + Start : Natural := Ids.Table (Id); + begin + for I in Res'Range loop + Res (I) := Strs.Table (Start + I - 1); + end loop; + return Res; + end Get_String; + + function Is_Equal (Id : O_Ident; Str : String) return Boolean + is + Start : Natural := Ids.Table (Id); + Len : Natural := Get_String_Length (Id); + begin + if Len /= Str'Length then + return False; + end if; + for I in Str'Range loop + if Str (I) /= Strs.Table (Start + I - Str'First) then + return False; + end if; + end loop; + return True; + end Is_Equal; + + function Is_Nul (Id : O_Ident) return Boolean is + begin + return Id = O_Ident_Nul; + end Is_Nul; + + procedure Disp_Stats + is + use Ada.Text_IO; + begin + Put_Line ("Number of Ident: " & O_Ident'Image (Ids.Last)); + Put_Line ("Number of Ident-Strs: " & Natural'Image (Strs.Last)); + end Disp_Stats; + + procedure Finish is + begin + Ids.Free; + Strs.Free; + end Finish; +end Ortho_Ident; diff --git a/ortho/mcode/ortho_ident.ads b/ortho/mcode/ortho_ident.ads new file mode 100644 index 0000000..fcf39b2 --- /dev/null +++ b/ortho/mcode/ortho_ident.ads @@ -0,0 +1,34 @@ +-- Mcode back-end for ortho. +-- 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 Ortho_Code; use Ortho_Code; + +package Ortho_Ident is + subtype O_Ident is Ortho_Code.O_Ident; + + function Get_Identifier (Str : String) return O_Ident; + function Is_Equal (L, R : O_Ident) return Boolean; + function Is_Equal (Id : O_Ident; Str : String) return Boolean; + function Is_Nul (Id : O_Ident) return Boolean; + function Get_String (Id : O_Ident) return String; + function Get_String_Length (Id : O_Ident) return Natural; + + O_Ident_Nul : constant O_Ident := Ortho_Code.O_Ident_Nul; + + procedure Disp_Stats; + procedure Finish; +end Ortho_Ident; diff --git a/ortho/mcode/ortho_mcode.adb b/ortho/mcode/ortho_mcode.adb new file mode 100644 index 0000000..6c91f26 --- /dev/null +++ b/ortho/mcode/ortho_mcode.adb @@ -0,0 +1,123 @@ +-- Mcode back-end for ortho. +-- 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 Ortho_Code.Abi; +with Ada.Text_IO; +with Ortho_Code.Debug; +with Ortho_Ident; +with Binary_File; + +package body Ortho_Mcode is + procedure New_Debug_Line_Decl (Line : Natural) + is + pragma Unreferenced (Line); + begin + null; + end New_Debug_Line_Decl; + + procedure New_Debug_Comment_Decl (Comment : String) + is + pragma Unreferenced (Comment); + begin + null; + end New_Debug_Comment_Decl; + + procedure New_Debug_Comment_Stmt (Comment : String) + is + pragma Unreferenced (Comment); + begin + null; + end New_Debug_Comment_Stmt; + + procedure Start_Declare_Stmt is + begin + Ortho_Code.Exprs.Start_Declare_Stmt; + end Start_Declare_Stmt; + + procedure Finish_Declare_Stmt is + begin + Ortho_Code.Exprs.Finish_Declare_Stmt; + end Finish_Declare_Stmt; + + procedure Start_Const_Value (Const : in out O_Dnode) + is + pragma Unreferenced (Const); + begin + null; + end Start_Const_Value; + + procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is + begin + New_Const_Value (Const, Val); + end Finish_Const_Value; + + function New_Obj_Value (Obj : O_Dnode) return O_Enode is + begin + return New_Value (New_Obj (Obj)); + end New_Obj_Value; + + function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) + return O_Tnode + is + L_Type : O_Tnode; + begin + L_Type := Get_Const_Type (Length); + if Get_Type_Kind (L_Type) /= OT_Unsigned then + raise Syntax_Error; + end if; + return New_Constrained_Array_Type (Atype, Get_Const_U32 (Length)); + end New_Constrained_Array_Type; + + procedure Init is + begin + -- Create an anonymous pointer type. + if New_Access_Type (O_Tnode_Null) /= O_Tnode_Ptr then + raise Program_Error; + end if; + -- Do not finish the access, since this creates an infinite recursion + -- in gdb (at least for GDB 6.3). + --Finish_Access_Type (O_Tnode_Ptr, O_Tnode_Ptr); + Ortho_Code.Abi.Init; + end Init; + + procedure Finish is + begin + if False then + Ortho_Code.Decls.Disp_All_Decls; + --Ortho_Code.Exprs.Disp_All_Enode; + end if; + Ortho_Code.Abi.Finish; + if Debug.Flag_Debug_Stat then + Ada.Text_IO.Put_Line ("Statistics:"); + Ortho_Code.Exprs.Disp_Stats; + Ortho_Code.Decls.Disp_Stats; + Ortho_Code.Types.Disp_Stats; + Ortho_Code.Consts.Disp_Stats; + Ortho_Ident.Disp_Stats; + Binary_File.Disp_Stats; + end if; + end Finish; + + procedure Free_All is + begin + Ortho_Code.Types.Finish; + Ortho_Code.Exprs.Finish; + Ortho_Code.Consts.Finish; + Ortho_Code.Decls.Finish; + Ortho_Ident.Finish; + end Free_All; +end Ortho_Mcode; diff --git a/ortho/mcode/ortho_mcode.ads b/ortho/mcode/ortho_mcode.ads new file mode 100644 index 0000000..d408d56 --- /dev/null +++ b/ortho/mcode/ortho_mcode.ads @@ -0,0 +1,516 @@ +-- Mcode back-end for ortho. +-- 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 Interfaces; use Interfaces; +with Ortho_Code; use Ortho_Code; +with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.Consts; use Ortho_Code.Consts; +with Ortho_Code.Decls; use Ortho_Code.Decls; +with Ortho_Code.Exprs; use Ortho_Code.Exprs; +with Ortho_Code.Abi; + +-- Interface to create nodes. +package Ortho_Mcode is + --- PUBLIC DECLARATIONS + subtype O_Tnode is Ortho_Code.O_Tnode; + subtype O_Cnode is Ortho_Code.O_Cnode; + subtype O_Dnode is Ortho_Code.O_Dnode; + subtype O_Enode is Ortho_Code.O_Enode; + subtype O_Fnode is Ortho_Code.O_Fnode; + subtype O_Lnode is Ortho_Code.O_Lnode; + subtype O_Snode is Ortho_Code.Exprs.O_Snode; + + O_Lnode_Null : constant O_Lnode := Ortho_Code.O_Lnode_Null; + O_Cnode_Null : constant O_Cnode := Ortho_Code.O_Cnode_Null; + O_Dnode_Null : constant O_Dnode := Ortho_Code.O_Dnode_Null; + O_Enode_Null : constant O_Enode := Ortho_Code.O_Enode_Null; + O_Fnode_Null : constant O_Fnode := Ortho_Code.O_Fnode_Null; + O_Snode_Null : O_Snode renames Ortho_Code.Exprs.O_Snode_Null; + O_Tnode_Null : constant O_Tnode := Ortho_Code.O_Tnode_Null; + function "=" (L, R : O_Tnode) return Boolean renames Ortho_Code."="; + function "=" (L, R : O_Cnode) return Boolean renames Ortho_Code."="; + function "=" (L, R : O_Snode) return Boolean renames Ortho_Code.Exprs."="; + function "=" (L, R : O_Dnode) return Boolean renames Ortho_Code."="; + function "=" (L, R : O_Enode) return Boolean renames Ortho_Code."="; + function "=" (L, R : O_Fnode) return Boolean renames Ortho_Code."="; + function "=" (L, R : O_Lnode) return Boolean renames Ortho_Code."="; + + -- Initialize nodes. + procedure Init; + procedure Finish; + + procedure Free_All; + + subtype O_Element_List is Ortho_Code.Types.O_Element_List; + + -- Build a record type. + procedure Start_Record_Type (Elements : out O_Element_List) + renames Ortho_Code.Types.Start_Record_Type; + + -- Add a field in the record; not constrained array are prohibited, since + -- its size is unlimited. + procedure New_Record_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; Etype : O_Tnode) + renames Ortho_Code.Types.New_Record_Field; + + -- Finish the record type. + procedure Finish_Record_Type + (Elements : in out O_Element_List; Res : out O_Tnode) + renames Ortho_Code.Types.Finish_Record_Type; + + -- Build an uncomplete record type: + -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type. + -- This type can be declared or used to define access types on it. + -- Then, complete (if necessary) the record type, by calling + -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE. + procedure New_Uncomplete_Record_Type (Res : out O_Tnode) + renames Ortho_Code.Types.New_Uncomplete_Record_Type; + procedure Start_Uncomplete_Record_Type (Res : O_Tnode; + Elements : out O_Element_List) + renames Ortho_Code.Types.Start_Uncomplete_Record_Type; + + -- Build an union type. + procedure Start_Union_Type (Elements : out O_Element_List) + renames Ortho_Code.Types.Start_Union_Type; + procedure New_Union_Field + (Elements : in out O_Element_List; + El : out O_Fnode; + Ident : O_Ident; + Etype : O_Tnode) + renames Ortho_Code.Types.New_Union_Field; + procedure Finish_Union_Type + (Elements : in out O_Element_List; Res : out O_Tnode) + renames Ortho_Code.Types.Finish_Union_Type; + + -- Build an access type. + -- DTYPE may be O_tnode_null in order to build an incomplete access type. + -- It is completed with finish_access_type. + function New_Access_Type (Dtype : O_Tnode) return O_Tnode + renames Ortho_Code.Types.New_Access_Type; + procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) + renames Ortho_Code.Types.Finish_Access_Type; + + -- Build an array type. + -- The array is not constrained and unidimensional. + function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) + return O_Tnode + renames Ortho_Code.Types.New_Array_Type; + + -- Build a constrained array type. + function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode) + return O_Tnode; + + -- Build a scalar type; size may be 8, 16, 32 or 64. + function New_Unsigned_Type (Size : Natural) return O_Tnode + renames Ortho_Code.Types.New_Unsigned_Type; + function New_Signed_Type (Size : Natural) return O_Tnode + renames Ortho_Code.Types.New_Signed_Type; + + -- Build a float type. + function New_Float_Type return O_Tnode + renames Ortho_Code.Types.New_Float_Type; + + -- Build a boolean type. + procedure New_Boolean_Type (Res : out O_Tnode; + False_Id : O_Ident; + False_E : out O_Cnode; + True_Id : O_Ident; + True_E : out O_Cnode) + renames Ortho_Code.Types.New_Boolean_Type; + + -- Create an enumeration + subtype O_Enum_List is Ortho_Code.Types.O_Enum_List; + + -- Elements are declared in order, the first is ordered from 0. + procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) + renames Ortho_Code.Types.Start_Enum_Type; + procedure New_Enum_Literal (List : in out O_Enum_List; + Ident : O_Ident; Res : out O_Cnode) + renames Ortho_Code.Types.New_Enum_Literal; + procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) + renames Ortho_Code.Types.Finish_Enum_Type; + + ------------------- + -- Expressions -- + ------------------- + + subtype ON_Op_Kind is Ortho_Code.ON_Op_Kind; + function "=" (L, R : ON_Op_Kind) return Boolean renames Ortho_Code."="; + + ON_Nil : constant ON_Op_Kind := Ortho_Code.ON_Nil; + + ON_Add_Ov : constant ON_Op_Kind := Ortho_Code.ON_Add_Ov; + ON_Sub_Ov : constant ON_Op_Kind := Ortho_Code.ON_Sub_Ov; + ON_Mul_Ov : constant ON_Op_Kind := Ortho_Code.ON_Mul_Ov; + ON_Div_Ov : constant ON_Op_Kind := Ortho_Code.ON_Div_Ov; + ON_Rem_Ov : constant ON_Op_Kind := Ortho_Code.ON_Rem_Ov; + ON_Mod_Ov : constant ON_Op_Kind := Ortho_Code.ON_Mod_Ov; + + ON_And : constant ON_Op_Kind := Ortho_Code.ON_And; + ON_Or : constant ON_Op_Kind := Ortho_Code.ON_Or; + ON_Xor : constant ON_Op_Kind := Ortho_Code.ON_Xor; + + -- Monadic operations. + ON_Not : constant ON_Op_Kind := Ortho_Code.ON_Not; + ON_Neg_Ov : constant ON_Op_Kind := Ortho_Code.ON_Neg_Ov; + ON_Abs_Ov : constant ON_Op_Kind := Ortho_Code.ON_Abs_Ov; + + -- Comparaisons + ON_Eq : constant ON_Op_Kind := Ortho_Code.ON_Eq; + ON_Neq : constant ON_Op_Kind := Ortho_Code.ON_Neq; + ON_Le : constant ON_Op_Kind := Ortho_Code.ON_Le; + ON_Lt : constant ON_Op_Kind := Ortho_Code.ON_Lt; + ON_Ge : constant ON_Op_Kind := Ortho_Code.ON_Ge; + ON_Gt : constant ON_Op_Kind := Ortho_Code.ON_Gt; + + subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor; + subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov; + subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt; + + subtype O_Storage is Ortho_Code.O_Storage; + O_Storage_Private : constant O_Storage := Ortho_Code.O_Storage_Private; + O_Storage_Local : constant O_Storage := Ortho_Code.O_Storage_Local; + O_Storage_Public : constant O_Storage := Ortho_Code.O_Storage_Public; + O_Storage_External : constant O_Storage := Ortho_Code.O_Storage_External; + function "=" (L, R : O_Storage) return Boolean renames Ortho_Code."="; + + Type_Error : exception; + Syntax_Error : exception; + + function New_Lit (Lit : O_Cnode) return O_Enode + renames Ortho_Code.Exprs.New_Lit; + + -- Create a dyadic operation. + -- Left and right nodes must have the same type. + -- Binary operation is allowed only on boolean types. + -- The result is of the type of the operands. + function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) + return O_Enode + renames Ortho_Code.Exprs.New_Dyadic_Op; + + -- Create a monadic operation. + -- Result is of the type of operand. + function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) + return O_Enode + renames Ortho_Code.Exprs.New_Monadic_Op; + + -- Create a comparaison operator. + -- NTYPE is the type of the result and must be a boolean type. + function New_Compare_Op + (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) + return O_Enode + renames Ortho_Code.Exprs.New_Compare_Op; + + -- Create a literal from an integer. + function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) + return O_Cnode + renames Ortho_Code.Consts.New_Signed_Literal; + function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) + return O_Cnode + renames Ortho_Code.Consts.New_Unsigned_Literal; + function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) + return O_Cnode + renames Ortho_Code.Consts.New_Float_Literal; + + -- Create a null access literal. + function New_Null_Access (Ltype : O_Tnode) return O_Cnode + renames Ortho_Code.Consts.New_Null_Access; + + subtype O_Inter_List is Ortho_Code.Decls.O_Inter_List; + subtype O_Record_Aggr_List is Ortho_Code.Consts.O_Record_Aggr_List; + subtype O_Array_Aggr_List is Ortho_Code.Consts.O_Array_Aggr_List; + subtype O_Assoc_List is Ortho_Code.Exprs.O_Assoc_List; + subtype O_If_Block is Ortho_Code.Exprs.O_If_Block; + subtype O_Case_Block is Ortho_Code.Exprs.O_Case_Block; + + + -- Build a record/array aggregate. + -- The aggregate is constant, and therefore can be only used to initialize + -- constant declaration. + -- ATYPE must be either a record type or an array subtype. + -- Elements must be added in the order, and must be literals or aggregates. + procedure Start_Record_Aggr (List : out O_Record_Aggr_List; + Atype : O_Tnode) + renames Ortho_Code.Consts.Start_Record_Aggr; + procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; + Value : O_Cnode) + renames Ortho_Code.Consts.New_Record_Aggr_El; + procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List; + Res : out O_Cnode) + renames Ortho_Code.Consts.Finish_Record_Aggr; + + procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) + renames Ortho_Code.Consts.Start_Array_Aggr; + procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; + Value : O_Cnode) + renames Ortho_Code.Consts.New_Array_Aggr_El; + procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List; + Res : out O_Cnode) + renames Ortho_Code.Consts.Finish_Array_Aggr; + + -- Build an union aggregate. + function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) + return O_Cnode + renames Ortho_Code.Consts.New_Union_Aggr; + + -- Returns the size in bytes of ATYPE. The result is a literal of + -- unsigned type RTYPE + -- ATYPE cannot be an unconstrained array type. + function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode + renames Ortho_Code.Consts.New_Sizeof; + + -- Returns the offset of FIELD in its record. The result is a literal + -- of unsigned type RTYPE. + function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Cnode + renames Ortho_Code.Consts.New_Offsetof; + + -- Get an element of an array. + -- INDEX must be of the type of the array index. + function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) + return O_Lnode + renames Ortho_Code.Exprs.New_Indexed_Element; + + -- Get a slice of an array; this is equivalent to a conversion between + -- an array or an array subtype and an array subtype. + -- RES_TYPE must be an array_sub_type whose base type is the same as the + -- base type of ARR. + -- INDEX must be of the type of the array index. + function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) + return O_Lnode + renames Ortho_Code.Exprs.New_Slice; + + -- Get an element of a record. + -- Type of REC must be a record type. + function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) + return O_Lnode + renames Ortho_Code.Exprs.New_Selected_Element; + + -- Reference an access. + -- Type of ACC must be an access type. + function New_Access_Element (Acc : O_Enode) return O_Lnode + renames Ortho_Code.Exprs.New_Access_Element; + + -- Do a conversion. + -- Allowed conversions are: + -- FIXME: to write. + function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode + renames Ortho_Code.Exprs.New_Convert_Ov; + + -- Get the address of LVALUE. + -- ATYPE must be a type access whose designated type is the type of LVALUE. + -- FIXME: what about arrays. + function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode + renames Ortho_Code.Exprs.New_Address; + function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode + renames Ortho_Code.Consts.New_Global_Address; + + -- Same as New_Address but without any restriction. + function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) + return O_Enode + renames Ortho_Code.Exprs.New_Unchecked_Address; + function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) + return O_Cnode + renames Ortho_Code.Consts.New_Global_Unchecked_Address; + + -- Get the address of a subprogram. + function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) + return O_Cnode + renames Ortho_Code.Consts.New_Subprogram_Address; + + -- Get the value of an Lvalue. + function New_Value (Lvalue : O_Lnode) return O_Enode + renames Ortho_Code.Exprs.New_Value; + + -- Get the value of object OBJ. + function New_Obj_Value (Obj : O_Dnode) return O_Enode; + + -- Return a pointer of type RTPE to SIZE bytes allocated on the stack. + function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode + renames Ortho_Code.Exprs.New_Alloca; + + --------------------- + -- Declarations. -- + --------------------- + + -- Following lines applies to FILENAME. + procedure New_Debug_Filename_Decl (Filename : String) + renames Ortho_Code.Abi.New_Debug_Filename_Decl; + + -- Line number of the next declaration. + procedure New_Debug_Line_Decl (Line : Natural); + + -- Add a comment in the declarative region. + procedure New_Debug_Comment_Decl (Comment : String); + + -- Declare a type. + -- This simply gives a name to a type. + procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) + renames Ortho_Code.Decls.New_Type_Decl; + + -- Declare a constant. + -- This simply gives a name to a constant value or aggregate. + -- A constant cannot be modified and its storage cannot be local. + -- ATYPE must be constrained. + procedure New_Const_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) + renames Ortho_Code.Decls.New_Const_Decl; + + -- Set the value of a non-external constant. + procedure Start_Const_Value (Const : in out O_Dnode); + procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode); + + -- Create a variable declaration. + -- A variable can be local only inside a function. + -- ATYPE must be constrained. + procedure New_Var_Decl + (Res : out O_Dnode; + Ident : O_Ident; + Storage : O_Storage; + Atype : O_Tnode) + renames Ortho_Code.Decls.New_Var_Decl; + + function New_Obj (Decl : O_Dnode) return O_Lnode + renames Ortho_Code.Exprs.New_Obj; + + -- Start a subprogram declaration. + -- Note: nested subprograms are allowed, ie o_storage_local subprograms can + -- be declared inside a subprograms. It is not allowed to declare + -- o_storage_external subprograms inside a subprograms. + -- Return type and interfaces cannot be a composite type. + procedure Start_Function_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage; + Rtype : O_Tnode) + renames Ortho_Code.Decls.Start_Function_Decl; + -- For a subprogram without return value. + procedure Start_Procedure_Decl + (Interfaces : out O_Inter_List; + Ident : O_Ident; + Storage : O_Storage) + renames Ortho_Code.Decls.Start_Procedure_Decl; + + -- Add an interface declaration to INTERFACES. + procedure New_Interface_Decl + (Interfaces : in out O_Inter_List; + Res : out O_Dnode; + Ident : O_Ident; + Atype : O_Tnode) + renames Ortho_Code.Decls.New_Interface_Decl; + -- Finish the function declaration, get the node and a statement list. + procedure Finish_Subprogram_Decl + (Interfaces : in out O_Inter_List; Res : out O_Dnode) + renames Ortho_Code.Decls.Finish_Subprogram_Decl; + -- Start a subprogram body. + -- Note: the declaration may have an external storage, in this case it + -- becomes public. + procedure Start_Subprogram_Body (Func : O_Dnode) + renames Ortho_Code.Exprs.Start_Subprogram_Body; + -- Finish a subprogram body. + procedure Finish_Subprogram_Body + renames Ortho_Code.Exprs.Finish_Subprogram_Body; + + + ------------------- + -- Statements. -- + ------------------- + + -- Add a line number as a statement. + procedure New_Debug_Line_Stmt (Line : Natural) + renames Ortho_Code.Exprs.New_Debug_Line_Stmt; + + -- Add a comment as a statement. + procedure New_Debug_Comment_Stmt (Comment : String); + + -- Start a declarative region. + procedure Start_Declare_Stmt; + procedure Finish_Declare_Stmt; + + -- Create a function call or a procedure call. + procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) + renames Ortho_Code.Exprs.Start_Association; + procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) + renames Ortho_Code.Exprs.New_Association; + function New_Function_Call (Assocs : O_Assoc_List) return O_Enode + renames Ortho_Code.Exprs.New_Function_Call; + procedure New_Procedure_Call (Assocs : in out O_Assoc_List) + renames Ortho_Code.Exprs.New_Procedure_Call; + + -- Assign VALUE to TARGET, type must be the same or compatible. + -- FIXME: what about slice assignment? + procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) + renames Ortho_Code.Exprs.New_Assign_Stmt; + + -- Exit from the subprogram and return VALUE. + procedure New_Return_Stmt (Value : O_Enode) + renames Ortho_Code.Exprs.New_Return_Stmt; + -- Exit from the subprogram, which doesn't return value. + procedure New_Return_Stmt + renames Ortho_Code.Exprs.New_Return_Stmt; + + -- Build an IF statement. + procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode) + renames Ortho_Code.Exprs.Start_If_Stmt; + -- COND is NULL for the final else statement. + procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) + renames Ortho_Code.Exprs.New_Elsif_Stmt; + procedure New_Else_Stmt (Block : in out O_If_Block) + renames Ortho_Code.Exprs.New_Else_Stmt; + procedure Finish_If_Stmt (Block : in out O_If_Block) + renames Ortho_Code.Exprs.Finish_If_Stmt; + + -- Create a infinite loop statement. + procedure Start_Loop_Stmt (Label : out O_Snode) + renames Ortho_Code.Exprs.Start_Loop_Stmt; + procedure Finish_Loop_Stmt (Label : in out O_Snode) + renames Ortho_Code.Exprs.Finish_Loop_Stmt; + + -- Exit from a loop stmt or from a for stmt. + procedure New_Exit_Stmt (L : O_Snode) + renames Ortho_Code.Exprs.New_Exit_Stmt; + -- Go to the start of a loop stmt or of a for stmt. + -- Loops/Fors between L and the current points are exited. + procedure New_Next_Stmt (L : O_Snode) + renames Ortho_Code.Exprs.New_Next_Stmt; + + -- Case statement. + -- VALUE is the selector and must be a discrete type. + procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode) + renames Ortho_Code.Exprs.Start_Case_Stmt; + + -- Start a branch before the choices. + procedure Start_Choice (Block : in out O_Case_Block) + renames Ortho_Code.Exprs.Start_Choice; + procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) + renames Ortho_Code.Exprs.New_Expr_Choice; + procedure New_Range_Choice (Block : in out O_Case_Block; + Low, High : O_Cnode) + renames Ortho_Code.Exprs.New_Range_Choice; + procedure New_Default_Choice (Block : in out O_Case_Block) + renames Ortho_Code.Exprs.New_Default_Choice; + -- Finish a branch after a choice, allow regular statements. + procedure Finish_Choice (Block : in out O_Case_Block) + renames Ortho_Code.Exprs.Finish_Choice; + procedure Finish_Case_Stmt (Block : in out O_Case_Block) + renames Ortho_Code.Exprs.Finish_Case_Stmt; +end Ortho_Mcode; diff --git a/ortho/mcode/ortho_nodes.ads b/ortho/mcode/ortho_nodes.ads new file mode 100644 index 0000000..7a2df3f --- /dev/null +++ b/ortho/mcode/ortho_nodes.ads @@ -0,0 +1,2 @@ +with Ortho_Mcode; +package Ortho_Nodes renames Ortho_Mcode; |