aboutsummaryrefslogtreecommitdiffstats
path: root/src/ortho/mcode
diff options
context:
space:
mode:
Diffstat (limited to 'src/ortho/mcode')
-rw-r--r--src/ortho/mcode/Makefile37
-rw-r--r--src/ortho/mcode/binary_file-coff.adb407
-rw-r--r--src/ortho/mcode/binary_file-coff.ads23
-rw-r--r--src/ortho/mcode/binary_file-elf.adb679
-rw-r--r--src/ortho/mcode/binary_file-elf.ads22
-rw-r--r--src/ortho/mcode/binary_file-memory.adb101
-rw-r--r--src/ortho/mcode/binary_file-memory.ads25
-rw-r--r--src/ortho/mcode/binary_file.adb977
-rw-r--r--src/ortho/mcode/binary_file.ads305
-rw-r--r--src/ortho/mcode/coff.ads208
-rw-r--r--src/ortho/mcode/coffdump.adb274
-rw-r--r--src/ortho/mcode/disa_sparc.adb274
-rw-r--r--src/ortho/mcode/disa_sparc.ads15
-rw-r--r--src/ortho/mcode/disa_x86.adb997
-rw-r--r--src/ortho/mcode/disa_x86.ads34
-rw-r--r--src/ortho/mcode/disassemble.ads3
-rw-r--r--src/ortho/mcode/dwarf.ads446
-rw-r--r--src/ortho/mcode/elf32.adb48
-rw-r--r--src/ortho/mcode/elf32.ads124
-rw-r--r--src/ortho/mcode/elf64.ads105
-rw-r--r--src/ortho/mcode/elf_arch.ads2
-rw-r--r--src/ortho/mcode/elf_arch32.ads37
-rw-r--r--src/ortho/mcode/elf_arch64.ads37
-rw-r--r--src/ortho/mcode/elf_common.adb48
-rw-r--r--src/ortho/mcode/elf_common.ads250
-rw-r--r--src/ortho/mcode/elfdump.adb267
-rw-r--r--src/ortho/mcode/elfdumper.adb2818
-rw-r--r--src/ortho/mcode/elfdumper.ads164
-rw-r--r--src/ortho/mcode/hex_images.adb71
-rw-r--r--src/ortho/mcode/hex_images.ads26
-rw-r--r--src/ortho/mcode/memsegs.ads3
-rw-r--r--src/ortho/mcode/memsegs_c.c133
-rw-r--r--src/ortho/mcode/memsegs_mmap.adb64
-rw-r--r--src/ortho/mcode/memsegs_mmap.ads49
-rw-r--r--src/ortho/mcode/ortho_code-abi.ads3
-rw-r--r--src/ortho/mcode/ortho_code-binary.adb37
-rw-r--r--src/ortho/mcode/ortho_code-binary.ads31
-rw-r--r--src/ortho/mcode/ortho_code-consts.adb559
-rw-r--r--src/ortho/mcode/ortho_code-consts.ads158
-rw-r--r--src/ortho/mcode/ortho_code-debug.adb143
-rw-r--r--src/ortho/mcode/ortho_code-debug.ads70
-rw-r--r--src/ortho/mcode/ortho_code-decls.adb783
-rw-r--r--src/ortho/mcode/ortho_code-decls.ads209
-rw-r--r--src/ortho/mcode/ortho_code-disps.adb790
-rw-r--r--src/ortho/mcode/ortho_code-disps.ads25
-rw-r--r--src/ortho/mcode/ortho_code-dwarf.adb1351
-rw-r--r--src/ortho/mcode/ortho_code-dwarf.ads41
-rw-r--r--src/ortho/mcode/ortho_code-exprs.adb1663
-rw-r--r--src/ortho/mcode/ortho_code-exprs.ads600
-rw-r--r--src/ortho/mcode/ortho_code-flags.ads35
-rw-r--r--src/ortho/mcode/ortho_code-opts.adb214
-rw-r--r--src/ortho/mcode/ortho_code-opts.ads22
-rw-r--r--src/ortho/mcode/ortho_code-types.adb820
-rw-r--r--src/ortho/mcode/ortho_code-types.ads240
-rw-r--r--src/ortho/mcode/ortho_code-x86-abi.adb762
-rw-r--r--src/ortho/mcode/ortho_code-x86-abi.ads76
-rw-r--r--src/ortho/mcode/ortho_code-x86-emits.adb2322
-rw-r--r--src/ortho/mcode/ortho_code-x86-emits.ads36
-rw-r--r--src/ortho/mcode/ortho_code-x86-flags_linux.ads31
-rw-r--r--src/ortho/mcode/ortho_code-x86-flags_macosx.ads31
-rw-r--r--src/ortho/mcode/ortho_code-x86-flags_windows.ads31
-rw-r--r--src/ortho/mcode/ortho_code-x86-insns.adb2068
-rw-r--r--src/ortho/mcode/ortho_code-x86-insns.ads25
-rw-r--r--src/ortho/mcode/ortho_code-x86.adb109
-rw-r--r--src/ortho/mcode/ortho_code-x86.ads160
-rw-r--r--src/ortho/mcode/ortho_code.ads150
-rw-r--r--src/ortho/mcode/ortho_code_main.adb198
-rw-r--r--src/ortho/mcode/ortho_ident.adb117
-rw-r--r--src/ortho/mcode/ortho_ident.ads38
-rw-r--r--src/ortho/mcode/ortho_jit.adb125
-rw-r--r--src/ortho/mcode/ortho_mcode-jit.adb28
-rw-r--r--src/ortho/mcode/ortho_mcode-jit.ads9
-rw-r--r--src/ortho/mcode/ortho_mcode.adb738
-rw-r--r--src/ortho/mcode/ortho_mcode.ads583
-rw-r--r--src/ortho/mcode/ortho_mcode.private.ads151
-rw-r--r--src/ortho/mcode/ortho_nodes.ads2
76 files changed, 24657 insertions, 0 deletions
diff --git a/src/ortho/mcode/Makefile b/src/ortho/mcode/Makefile
new file mode 100644
index 000000000..19d5d26aa
--- /dev/null
+++ b/src/ortho/mcode/Makefile
@@ -0,0 +1,37 @@
+ortho_srcdir=..
+GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwlcru -gnat05
+CC=gcc
+BE=mcode
+SED=sed
+
+all: $(ortho_exec)
+
+$(ortho_exec): $(ortho_srcdir)/mcode/ortho_mcode.ads 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.. -largs memsegs_c.o
+
+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
+
+ORTHO_BASENAME=ortho_mcode
+include $(ortho_srcdir)/Makefile.inc
diff --git a/src/ortho/mcode/binary_file-coff.adb b/src/ortho/mcode/binary_file-coff.adb
new file mode 100644
index 000000000..cf3cba3f4
--- /dev/null
+++ b/src/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 : constant 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/src/ortho/mcode/binary_file-coff.ads b/src/ortho/mcode/binary_file-coff.ads
new file mode 100644
index 000000000..e671555ea
--- /dev/null
+++ b/src/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/src/ortho/mcode/binary_file-elf.adb b/src/ortho/mcode/binary_file-elf.adb
new file mode 100644
index 000000000..329dbacd3
--- /dev/null
+++ b/src/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/src/ortho/mcode/binary_file-elf.ads b/src/ortho/mcode/binary_file-elf.ads
new file mode 100644
index 000000000..e0d3a4d2a
--- /dev/null
+++ b/src/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/src/ortho/mcode/binary_file-memory.adb b/src/ortho/mcode/binary_file-memory.adb
new file mode 100644
index 000000000..a37af9cb7
--- /dev/null
+++ b/src/ortho/mcode/binary_file-memory.adb
@@ -0,0 +1,101 @@
+-- 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;
+
+ function To_Pc_Type is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Pc_Type);
+
+ procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address)
+ is
+ begin
+ Set_Symbol_Value (Sym, To_Pc_Type (Addr));
+ Set_Scope (Sym, Sym_Global);
+ Set_Section (Sym, Sect_Abs);
+ end Set_Symbol_Address;
+
+ procedure Write_Memory_Init is
+ begin
+ Create_Section (Sect_Abs, "*ABS*", Section_Exec);
+ Sect_Abs.Vaddr := 0;
+ end Write_Memory_Init;
+
+ procedure Write_Memory_Relocate (Error : out Boolean)
+ is
+ Sect : Section_Acc;
+ Rel : Reloc_Acc;
+ N_Rel : Reloc_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
+ and (Sect /= Sect_Abs and Sect.Flags /= Section_Debug)
+ then
+ Sect.Vaddr := To_Pc_Type (Sect.Data (0)'Address);
+ end if;
+ Sect := Sect.Next;
+ end loop;
+
+ -- 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/src/ortho/mcode/binary_file-memory.ads b/src/ortho/mcode/binary_file-memory.ads
new file mode 100644
index 000000000..a205da527
--- /dev/null
+++ b/src/ortho/mcode/binary_file-memory.ads
@@ -0,0 +1,25 @@
+-- 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
+
+ -- Must be called before set_symbol_address.
+ 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/src/ortho/mcode/binary_file.adb b/src/ortho/mcode/binary_file.adb
new file mode 100644
index 000000000..6043d7319
--- /dev/null
+++ b/src/ortho/mcode/binary_file.adb
@@ -0,0 +1,977 @@
+-- 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.Storage_Elements;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Characters.Latin_1;
+with Ada.Unchecked_Conversion;
+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;
+ pragma Unreferenced (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 : 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 : constant 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 .. 256);
+ 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
+ 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 Pc_Type is
+ begin
+ return Get_Section (Sym).Vaddr + 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 := Unsigned_32 (Get_Symbol_Vaddr (Sym) - (Sect.Vaddr + 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, Unsigned_32 (Get_Symbol_Vaddr (Sym)));
+
+ when Reloc_Pc32 =>
+ Add_Le32 (Sect, Addr,
+ Unsigned_32 (Get_Symbol_Vaddr (Sym)
+ - (Sect.Vaddr + 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,
+ Unsigned_32 (Get_Symbol_Vaddr (Sym) / 1024));
+ when Reloc_Lo10 =>
+ Write_Left_Be32 (Sect, Addr, 10,
+ Unsigned_32 (Get_Symbol_Vaddr (Sym)));
+ when Reloc_Ua_32 =>
+ Write_Be32 (Sect, Addr, Unsigned_32 (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
+ begin
+ Put_Line ("Number of Symbols: " & Symbol'Image (Symbols.Last));
+ end Disp_Stats;
+
+ procedure Finish
+ is
+ Sect : Section_Acc;
+ Rel, N_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;
+ 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/src/ortho/mcode/binary_file.ads b/src/ortho/mcode/binary_file.ads
new file mode 100644
index 000000000..1a2bf588d
--- /dev/null
+++ b/src/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 System;
+with Interfaces; use Interfaces;
+with Ada.Unchecked_Deallocation;
+with Ortho_Ident; use Ortho_Ident;
+with GNAT.Table;
+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;
+ Section_Debug : 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 : 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 Pc_Type;
+ 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
+ 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 : Pc_Type; -- 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_Debug : constant Section_Flags := 2#0010_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/src/ortho/mcode/coff.ads b/src/ortho/mcode/coff.ads
new file mode 100644
index 000000000..6ef9cdde9
--- /dev/null
+++ b/src/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/src/ortho/mcode/coffdump.adb b/src/ortho/mcode/coffdump.adb
new file mode 100644
index 000000000..6384b6c27
--- /dev/null
+++ b/src/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/src/ortho/mcode/disa_sparc.adb b/src/ortho/mcode/disa_sparc.adb
new file mode 100644
index 000000000..8c9176ff8
--- /dev/null
+++ b/src/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/src/ortho/mcode/disa_sparc.ads b/src/ortho/mcode/disa_sparc.ads
new file mode 100644
index 000000000..486dff977
--- /dev/null
+++ b/src/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/src/ortho/mcode/disa_x86.adb b/src/ortho/mcode/disa_x86.adb
new file mode 100644
index 000000000..1d2d48565
--- /dev/null
+++ b/src/ortho/mcode/disa_x86.adb
@@ -0,0 +1,997 @@
+-- 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.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
+ (
+ N_None,
+ N_Push,
+ N_Pop,
+ N_Ret,
+ N_Mov,
+ N_Add,
+ N_Or,
+ N_Adc,
+ N_Sbb,
+ N_And,
+ N_Sub,
+ N_Xor,
+ N_Cmp,
+ N_Into,
+ N_Jmp,
+ N_Jcc,
+ N_Setcc,
+ N_Call,
+ N_Int,
+ N_Cdq,
+ N_Imul,
+ N_Mul,
+ N_Leave,
+ N_Test,
+ N_Lea,
+ N_O,
+ N_No,
+ N_B,
+ N_AE,
+ N_E,
+ N_Ne,
+ N_Be,
+ N_A,
+ N_S,
+ N_Ns,
+ N_P,
+ N_Np,
+ N_L,
+ N_Ge,
+ N_Le,
+ N_G,
+ N_Not,
+ N_Neg,
+ N_Cbw,
+ N_Div,
+ N_Idiv,
+ N_Movsx,
+ N_Movzx,
+ N_Nop,
+ N_Hlt,
+ N_Inc,
+ N_Dec,
+ N_Rol,
+ N_Ror,
+ N_Rcl,
+ N_Rcr,
+ N_Shl,
+ N_Shr,
+ N_Sar,
+ N_Fadd,
+ N_Fmul,
+ N_Fcom,
+ N_Fcomp,
+ N_Fsub,
+ N_Fsubr,
+ N_Fdiv,
+ N_Fdivr,
+
+ G_1,
+ G_2,
+ G_3,
+ G_5
+ );
+
+ type Names_Type is array (Index_Type range <>) of Cstring_Acc;
+ 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"),
+ N_Fadd => new S'("fadd"),
+ N_Fmul => new S'("fmul"),
+ N_Fcom => new S'("fcom"),
+ N_Fcomp => new S'("fcomp"),
+ N_Fsub => new S'("fsub"),
+ N_Fsubr => new S'("fsubr"),
+ N_Fdiv => new S'("fdiv"),
+ N_Fdivr => new S'("fdivr")
+ );
+
+
+
+ -- 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 (Index_Type'Val (Index_Type'Pos (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/src/ortho/mcode/disa_x86.ads b/src/ortho/mcode/disa_x86.ads
new file mode 100644
index 000000000..c215cf0a3
--- /dev/null
+++ b/src/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/src/ortho/mcode/disassemble.ads b/src/ortho/mcode/disassemble.ads
new file mode 100644
index 000000000..5c9811fed
--- /dev/null
+++ b/src/ortho/mcode/disassemble.ads
@@ -0,0 +1,3 @@
+with Disa_X86;
+
+package Disassemble renames Disa_X86;
diff --git a/src/ortho/mcode/dwarf.ads b/src/ortho/mcode/dwarf.ads
new file mode 100644
index 000000000..40ee94f10
--- /dev/null
+++ b/src/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/src/ortho/mcode/elf32.adb b/src/ortho/mcode/elf32.adb
new file mode 100644
index 000000000..ef58fe64b
--- /dev/null
+++ b/src/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/src/ortho/mcode/elf32.ads b/src/ortho/mcode/elf32.ads
new file mode 100644
index 000000000..5afd317f6
--- /dev/null
+++ b/src/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/src/ortho/mcode/elf64.ads b/src/ortho/mcode/elf64.ads
new file mode 100644
index 000000000..217e5557a
--- /dev/null
+++ b/src/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/src/ortho/mcode/elf_arch.ads b/src/ortho/mcode/elf_arch.ads
new file mode 100644
index 000000000..325c4e5e3
--- /dev/null
+++ b/src/ortho/mcode/elf_arch.ads
@@ -0,0 +1,2 @@
+with Elf_Arch32;
+package Elf_Arch renames Elf_Arch32;
diff --git a/src/ortho/mcode/elf_arch32.ads b/src/ortho/mcode/elf_arch32.ads
new file mode 100644
index 000000000..5e987b1e6
--- /dev/null
+++ b/src/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/src/ortho/mcode/elf_arch64.ads b/src/ortho/mcode/elf_arch64.ads
new file mode 100644
index 000000000..504cd66b3
--- /dev/null
+++ b/src/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/src/ortho/mcode/elf_common.adb b/src/ortho/mcode/elf_common.adb
new file mode 100644
index 000000000..5d05a2dc7
--- /dev/null
+++ b/src/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/src/ortho/mcode/elf_common.ads b/src/ortho/mcode/elf_common.ads
new file mode 100644
index 000000000..28186d094
--- /dev/null
+++ b/src/ortho/mcode/elf_common.ads
@@ -0,0 +1,250 @@
+-- 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;
+
+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/src/ortho/mcode/elfdump.adb b/src/ortho/mcode/elfdump.adb
new file mode 100644
index 000000000..d49275912
--- /dev/null
+++ b/src/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/src/ortho/mcode/elfdumper.adb b/src/ortho/mcode/elfdumper.adb
new file mode 100644
index 000000000..b3a3b70f2
--- /dev/null
+++ b/src/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/src/ortho/mcode/elfdumper.ads b/src/ortho/mcode/elfdumper.ads
new file mode 100644
index 000000000..0227f0f41
--- /dev/null
+++ b/src/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/src/ortho/mcode/hex_images.adb b/src/ortho/mcode/hex_images.adb
new file mode 100644
index 000000000..a9dca324d
--- /dev/null
+++ b/src/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/src/ortho/mcode/hex_images.ads b/src/ortho/mcode/hex_images.ads
new file mode 100644
index 000000000..830d2ec43
--- /dev/null
+++ b/src/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/src/ortho/mcode/memsegs.ads b/src/ortho/mcode/memsegs.ads
new file mode 100644
index 000000000..ff7f8947e
--- /dev/null
+++ b/src/ortho/mcode/memsegs.ads
@@ -0,0 +1,3 @@
+with Memsegs_Mmap;
+package Memsegs renames Memsegs_Mmap;
+
diff --git a/src/ortho/mcode/memsegs_c.c b/src/ortho/mcode/memsegs_c.c
new file mode 100644
index 000000000..f0a0e27d5
--- /dev/null
+++ b/src/ortho/mcode/memsegs_c.c
@@ -0,0 +1,133 @@
+/* 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.
+*/
+
+#ifdef __APPLE__
+#define MAP_ANONYMOUS MAP_ANON
+#else
+#define HAVE_MREMAP
+#endif
+
+#ifndef HAVE_MREMAP
+#include <string.h>
+#endif
+
+void *
+mmap_malloc (int size)
+{
+ void *res;
+ res = mmap (NULL, size, PROT_READ | PROT_WRITE,
+ MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
+ /* printf ("mmap (%d) = %p\n", size, res); */
+ if (res == MAP_FAILED)
+ return NULL;
+ return res;
+}
+
+void *
+mmap_realloc (void *ptr, int old_size, int size)
+{
+ void *res;
+#ifdef HAVE_MREMAP
+ res = mremap (ptr, old_size, size, MREMAP_MAYMOVE);
+#else
+ res = mmap (NULL, size, PROT_READ | PROT_WRITE,
+ MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
+ if (res == MAP_FAILED)
+ return NULL;
+ memcpy (res, ptr, old_size);
+ munmap (ptr, old_size);
+#endif
+ /* 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/src/ortho/mcode/memsegs_mmap.adb b/src/ortho/mcode/memsegs_mmap.adb
new file mode 100644
index 000000000..1ee8e7bcf
--- /dev/null
+++ b/src/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/src/ortho/mcode/memsegs_mmap.ads b/src/ortho/mcode/memsegs_mmap.ads
new file mode 100644
index 000000000..ba7d76618
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-abi.ads b/src/ortho/mcode/ortho_code-abi.ads
new file mode 100644
index 000000000..e75b08509
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-binary.adb b/src/ortho/mcode/ortho_code-binary.adb
new file mode 100644
index 000000000..7bb6bdd28
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-binary.ads b/src/ortho/mcode/ortho_code-binary.ads
new file mode 100644
index 000000000..58c79d3b2
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb
new file mode 100644
index 000000000..d09a13c34
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-consts.adb
@@ -0,0 +1,559 @@
+-- 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;
+ for Cnode_Common use record
+ Kind at 0 range 0 .. 31;
+ Lit_Type at 4 range 0 .. 31;
+ end record;
+ for Cnode_Common'Size use 64;
+
+ type Cnode_Signed is record
+ Val : Integer_64;
+ end record;
+ for Cnode_Signed'Size use 64;
+
+ type Cnode_Unsigned is record
+ Val : Unsigned_64;
+ end record;
+ for Cnode_Unsigned'Size use 64;
+
+ type Cnode_Float is record
+ Val : IEEE_Float_64;
+ end record;
+ for Cnode_Float'Size use 64;
+
+ type Cnode_Enum is record
+ Id : O_Ident;
+ Val : Uns32;
+ end record;
+ for Cnode_Enum'Size use 64;
+
+ type Cnode_Addr is record
+ Decl : O_Dnode;
+ Pad : Int32;
+ end record;
+ for Cnode_Addr'Size use 64;
+
+ type Cnode_Aggr is record
+ Els : Int32;
+ Nbr : Int32;
+ end record;
+ for Cnode_Aggr'Size use 64;
+
+ type Cnode_Sizeof is record
+ Atype : O_Tnode;
+ Pad : Int32;
+ end record;
+ for Cnode_Sizeof'Size use 64;
+
+ type Cnode_Union is record
+ El : O_Cnode;
+ Field : O_Fnode;
+ end record;
+ for Cnode_Union'Size use 64;
+
+ 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 Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_64
+ is
+ function To_Cnode_Float is new Ada.Unchecked_Conversion
+ (Cnode_Common, Cnode_Float);
+ begin
+ return To_Cnode_Float (Cnodes.Table (Cst + 1)).Val;
+ end Get_Const_F64;
+
+ 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 => Unsigned_64, 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 (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 New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode
+ is
+ Res : O_Cnode;
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Float, Target => Cnode_Common);
+ 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
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Union, Target => Cnode_Common);
+
+ Res : O_Cnode;
+ begin
+ if Debug.Flag_Debug_Hli then
+ Cnodes.Append (Cnode_Common'(Kind => OC_Union,
+ Lit_Type => Atype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Union'(El => Value,
+ Field => Field)));
+ return Res;
+ else
+ return Value;
+ end if;
+ end New_Union_Aggr;
+
+ function To_Cnode_Union is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Cnode_Union);
+
+ function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode is
+ begin
+ return To_Cnode_Union (Cnodes.Table (Cst + 1)).Field;
+ end Get_Const_Union_Field;
+
+ function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode is
+ begin
+ return To_Cnode_Union (Cnodes.Table (Cst + 1)).El;
+ end Get_Const_Union_Value;
+
+ 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_Alignof (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_Alignof,
+ 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_Align_Bytes (Atype)));
+ end if;
+ end New_Alignof;
+
+ function Get_Alignof_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_Alignof_Type;
+
+ function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode is
+ begin
+ if Get_Field_Parent (Field) /= Rec_Type then
+ raise Syntax_Error;
+ end if;
+ 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_Union
+ | OC_Sizeof
+ | OC_Alignof
+ | 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/src/ortho/mcode/ortho_code-consts.ads b/src/ortho/mcode/ortho_code-consts.ads
new file mode 100644
index 000000000..0076bc6eb
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-consts.ads
@@ -0,0 +1,158 @@
+-- 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_Union,
+ OC_Subprg_Address, OC_Address,
+ OC_Sizeof, OC_Alignof);
+
+ 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;
+
+ function Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_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;
+
+ -- Only available in HLI.
+ function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode;
+ function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode;
+
+ -- Declaration for an address.
+ function Get_Const_Decl (Cst : O_Cnode) return O_Dnode;
+
+ -- Get the type from an OC_Sizeof node.
+ function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode;
+
+ -- Get the type from an OC_Alignof node.
+ function Get_Alignof_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 alignment in bytes for ATYPE. The result is a literal of
+ -- unsgined type RTYPE.
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the offset of FIELD in its record REC_TYPE. The result is a
+ -- literal of unsigned type or access type RTYPE.
+ function New_Offsetof (Rec_Type : O_Tnode; 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/src/ortho/mcode/ortho_code-debug.adb b/src/ortho/mcode/ortho_code-debug.adb
new file mode 100644
index 000000000..0f3e01ab9
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-debug.adb
@@ -0,0 +1,143 @@
+-- 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 't' =>
+ Flags.Flag_Type_Name := 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/src/ortho/mcode/ortho_code-debug.ads b/src/ortho/mcode/ortho_code-debug.ads
new file mode 100644
index 000000000..03f550ac9
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-decls.adb b/src/ortho/mcode/ortho_code-decls.adb
new file mode 100644
index 000000000..fcbf0b0de
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-decls.adb
@@ -0,0 +1,783 @@
+-- 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_Subprg_Ext =>
+ -- Chain of interfaces.
+ Subprg_Inter : O_Dnode;
+
+ 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;
+
+ Use_Subprg_Ext : constant Boolean := False;
+
+ 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 OD_Function
+ | OD_Procedure =>
+ if Use_Subprg_Ext then
+ return Decl + 2;
+ else
+ return Decl + 1;
+ end if;
+ 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;
+ begin
+ if Use_Subprg_Ext then
+ Res := Decl + 2;
+ else
+ Res := Decl + 1;
+ end if;
+
+ 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 : constant 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
+ -- Value was already set.
+ 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;
+
+ New_Interface_Decl (Interfaces, Res, Static_Chain_Id, O_Tnode_Ptr);
+ end Add_Static_Chain;
+
+ procedure Start_Subprogram_Decl (Interfaces : out O_Inter_List)
+ is
+ Storage : O_Storage;
+ Decl : constant O_Dnode := Dnodes.Last;
+ begin
+ Storage := Get_Decl_Storage (Decl);
+ 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 (Decl, Storage);
+ end case;
+ end if;
+ if Use_Subprg_Ext then
+ Dnodes.Append (Dnode_Common'(Kind => OD_Subprg_Ext,
+ Storage => Storage,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Subprg_Inter => O_Dnode_Null,
+ others => False));
+ end if;
+
+ Start_Subprogram (Decl, Interfaces.Abi);
+ Interfaces.Decl := Decl;
+ 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 OD_Subprg_Ext =>
+ Put ("Subprg_Ext");
+-- 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 Debug_Decl (Decl : O_Dnode) is
+ begin
+ Disp_Decl (1, Decl);
+ end Debug_Decl;
+
+ pragma Unreferenced (Debug_Decl);
+
+ 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/src/ortho/mcode/ortho_code-decls.ads b/src/ortho/mcode/ortho_code-decls.ads
new file mode 100644
index 000000000..ad18892fe
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-decls.ads
@@ -0,0 +1,209 @@
+-- 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,
+
+ -- Global and local variables.
+ OD_Var, OD_Local,
+
+ -- Subprograms.
+ OD_Function, OD_Procedure,
+
+ -- Additional node for a subprogram. Internal use only.
+ OD_Subprg_Ext,
+
+ 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/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb
new file mode 100644
index 000000000..9e8ac1272
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-disps.adb
@@ -0,0 +1,790 @@
+-- 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_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 OC_Union =>
+ Put ('{');
+ Put ('.');
+ Disp_Ident (Types.Get_Field_Ident (Get_Const_Union_Field (Lit)));
+ Put ('=');
+ Disp_Lit (Get_Const_Union_Value (Lit));
+ Put ('}');
+ 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 OT_Complete =>
+ Put ("-- complete: ");
+ Disp_Type (Get_Type_Complete_Type (Atype));
+ 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 (" : ");
+ Dtype := Get_Decl_Type (Decl);
+ Disp_Type (Dtype);
+ if True then
+ Put (" {size="
+ & Uns32'Image (Types.Get_Type_Size (Dtype)) & "}");
+ end if;
+ 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 OD_Block | OD_Subprg_Ext =>
+ null;
+ 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 ("--#" & 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_Else =>
+ Disp_Indent (Indent - 1);
+ Put ("else");
+ 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;
+ begin
+ Stmt := S_Entry;
+ loop
+ Stmt := Get_Stmt_Link (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/src/ortho/mcode/ortho_code-disps.ads b/src/ortho/mcode/ortho_code-disps.ads
new file mode 100644
index 000000000..5ae4d8697
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-disps.ads
@@ -0,0 +1,25 @@
+-- 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 Disp_Type (Atype : O_Tnode; Force : Boolean := False);
+ procedure Init;
+ procedure Finish;
+end Ortho_Code.Disps;
diff --git a/src/ortho/mcode/ortho_code-dwarf.adb b/src/ortho/mcode/ortho_code-dwarf.adb
new file mode 100644
index 000000000..ad67d1ff6
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-dwarf.adb
@@ -0,0 +1,1351 @@
+-- Mcode back-end for ortho - Dwarf generator.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.Directory_Operations;
+with GNAT.Table;
+with Interfaces; use Interfaces;
+with Binary_File; use Binary_File;
+with Dwarf; use Dwarf;
+with Ada.Text_IO;
+with Ortho_Code.Decls;
+with Ortho_Code.Types;
+with Ortho_Code.Consts;
+with Ortho_Code.Flags;
+with Ortho_Ident;
+with Ortho_Code.Binary;
+
+package body Ortho_Code.Dwarf is
+ -- Dwarf debugging format.
+ -- Debugging.
+ Line1_Sect : Section_Acc := null;
+ Line_Last : Int32 := 0;
+ Line_Pc : Pc_Type := 0;
+
+ -- Constant.
+ Min_Insn_Len : constant := 1;
+ Line_Base : constant := 1;
+ Line_Range : constant := 4;
+ Line_Opcode_Base : constant := 13;
+ Line_Max_Addr : constant := (255 - Line_Opcode_Base) / Line_Range;
+ -- + Line_Base;
+
+ Cur_File : Natural := 0;
+ Last_File : Natural := 0;
+
+ Orig_Sym : Symbol;
+ End_Sym : Symbol;
+ Abbrev_Sym : Symbol;
+ Info_Sym : Symbol;
+ Line_Sym : Symbol;
+
+ Line_Sect : Section_Acc;
+ Abbrev_Sect : Section_Acc;
+ Info_Sect : Section_Acc;
+ Aranges_Sect : Section_Acc;
+
+ Abbrev_Last : Unsigned_32;
+
+-- procedure Gen_String (Str : String)
+-- is
+-- begin
+-- for I in Str'Range loop
+-- Gen_B8 (Character'Pos (Str (I)));
+-- end loop;
+-- end Gen_String;
+
+ procedure Gen_String_Nul (Str : String)
+ is
+ begin
+ Prealloc (Str'Length + 1);
+ for I in Str'Range loop
+ Gen_B8 (Character'Pos (Str (I)));
+ end loop;
+ Gen_B8 (0);
+ end Gen_String_Nul;
+
+ procedure Gen_Sleb128 (V : Int32)
+ is
+ V1 : Uns32 := To_Uns32 (V);
+ V2 : Uns32;
+ B : Byte;
+ function Shift_Right_Arithmetic (Value : Uns32; Amount : Natural)
+ return Uns32;
+ pragma Import (Intrinsic, Shift_Right_Arithmetic);
+ begin
+ loop
+ B := Byte (V1 and 16#7F#);
+ V2 := Shift_Right_Arithmetic (V1, 7);
+ if (V2 = 0 and (B and 16#40#) = 0)
+ or (V2 = -1 and (B and 16#40#) /= 0)
+ then
+ Gen_B8 (B);
+ exit;
+ else
+ Gen_B8 (B or 16#80#);
+ V1 := V2;
+ end if;
+ end loop;
+ end Gen_Sleb128;
+
+ procedure Gen_Uleb128 (V : Unsigned_32)
+ is
+ V1 : Unsigned_32 := V;
+ B : Byte;
+ begin
+ loop
+ B := Byte (V1 and 16#7f#);
+ V1 := Shift_Right (V1, 7);
+ if V1 /= 0 then
+ Gen_B8 (B or 16#80#);
+ else
+ Gen_B8 (B);
+ exit;
+ end if;
+ end loop;
+ end Gen_Uleb128;
+
+-- procedure New_Debug_Line_Decl (Line : Int32)
+-- is
+-- begin
+-- Line_Last := Line;
+-- end New_Debug_Line_Decl;
+
+ procedure Set_Line_Stmt (Line : Int32)
+ is
+ Pc : Pc_Type;
+ D_Pc : Pc_Type;
+ D_Ln : Int32;
+ begin
+ if Line = Line_Last then
+ return;
+ end if;
+ Pc := Get_Current_Pc;
+
+ D_Pc := (Pc - Line_Pc) / Min_Insn_Len;
+ D_Ln := Line - Line_Last;
+
+ -- Always emit line information, since missing info can distrub the
+ -- user.
+ -- As an optimization, we could try to emit the highest line for the
+ -- same PC, since GDB seems to handle this way.
+ if False and D_Pc = 0 then
+ return;
+ end if;
+
+ Set_Current_Section (Line1_Sect);
+ Prealloc (32);
+
+ if Cur_File /= Last_File then
+ Gen_B8 (Byte (DW_LNS_Set_File));
+ Gen_Uleb128 (Unsigned_32 (Cur_File));
+ Last_File := Cur_File;
+ elsif Cur_File = 0 then
+ return;
+ end if;
+
+ if D_Ln < Line_Base or D_Ln >= (Line_Base + Line_Range) then
+ -- Emit an advance line.
+ Gen_B8 (Byte (DW_LNS_Advance_Line));
+ Gen_Sleb128 (Int32 (D_Ln - Line_Base));
+ D_Ln := Line_Base;
+ end if;
+ if D_Pc >= Line_Max_Addr then
+ -- Emit an advance addr.
+ Gen_B8 (Byte (DW_LNS_Advance_Pc));
+ Gen_Uleb128 (Unsigned_32 (D_Pc));
+ D_Pc := 0;
+ end if;
+ Gen_B8 (Line_Opcode_Base
+ + Byte (D_Pc) * Line_Range
+ + Byte (D_Ln - Line_Base));
+
+ --Set_Current_Section (Text_Sect);
+ Line_Pc := Pc;
+ Line_Last := Line;
+ end Set_Line_Stmt;
+
+
+ type String_Acc is access constant String;
+
+ type Dir_Chain;
+ type Dir_Chain_Acc is access Dir_Chain;
+ type Dir_Chain is record
+ Name : String_Acc;
+ Next : Dir_Chain_Acc;
+ end record;
+
+ type File_Chain;
+ type File_Chain_Acc is access File_Chain;
+ type File_Chain is record
+ Name : String_Acc;
+ Dir : Natural;
+ Next : File_Chain_Acc;
+ end record;
+
+ Dirs : Dir_Chain_Acc := null;
+ Files : File_Chain_Acc := null;
+
+ procedure Set_Filename (Dir : String; File : String)
+ is
+ D : Natural;
+ F : Natural;
+ D_C : Dir_Chain_Acc;
+ F_C : File_Chain_Acc;
+ begin
+ -- Find directory.
+ if Dir = "" then
+ -- Current directory.
+ D := 0;
+ elsif Dirs = null then
+ -- First directory.
+ Dirs := new Dir_Chain'(Name => new String'(Dir),
+ Next => null);
+ D := 1;
+ else
+ -- Find a directory.
+ D_C := Dirs;
+ D := 1;
+ loop
+ exit when D_C.Name.all = Dir;
+ D := D + 1;
+ if D_C.Next = null then
+ D_C.Next := new Dir_Chain'(Name => new String'(Dir),
+ Next => null);
+ exit;
+ else
+ D_C := D_C.Next;
+ end if;
+ end loop;
+ end if;
+
+ -- Find file.
+ F := 1;
+ if Files = null then
+ -- first file.
+ Files := new File_Chain'(Name => new String'(File),
+ Dir => D,
+ Next => null);
+ else
+ F_C := Files;
+ loop
+ exit when F_C.Name.all = File and F_C.Dir = D;
+ F := F + 1;
+ if F_C.Next = null then
+ F_C.Next := new File_Chain'(Name => new String'(File),
+ Dir => D,
+ Next => null);
+ exit;
+ else
+ F_C := F_C.Next;
+ end if;
+ end loop;
+ end if;
+ Cur_File := F;
+ end Set_Filename;
+
+ procedure Gen_Abbrev_Header (Tag : Unsigned_32; Child : Byte) is
+ begin
+ Gen_Uleb128 (Tag);
+ Gen_B8 (Child);
+ end Gen_Abbrev_Header;
+
+ procedure Gen_Abbrev_Tuple (Attr : Unsigned_32; Form : Unsigned_32) is
+ begin
+ Gen_Uleb128 (Attr);
+ Gen_Uleb128 (Form);
+ end Gen_Abbrev_Tuple;
+
+ procedure Init
+ is
+ begin
+ -- Generate type names.
+ Flags.Flag_Type_Name := True;
+
+
+ Orig_Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Orig_Sym, False);
+ End_Sym := Create_Local_Symbol;
+
+ Create_Section (Line1_Sect, ".debug_line-1", Section_Debug);
+ Set_Current_Section (Line1_Sect);
+
+ -- Write Address.
+ Gen_B8 (0); -- extended opcode
+ Gen_B8 (5); -- length: 1 + 4
+ Gen_B8 (Byte (DW_LNE_Set_Address));
+ Gen_Ua_32 (Orig_Sym, 0);
+
+ Line_Last := 1;
+
+ Create_Section (Line_Sect, ".debug_line", Section_Debug);
+ Set_Section_Info (Line_Sect, null, 0, 0);
+ Set_Current_Section (Line_Sect);
+ Line_Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Line_Sym, False);
+
+ -- Abbrevs.
+ Create_Section (Abbrev_Sect, ".debug_abbrev", Section_Debug);
+ Set_Section_Info (Abbrev_Sect, null, 0, 0);
+ Set_Current_Section (Abbrev_Sect);
+
+ Abbrev_Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Abbrev_Sym, False);
+
+ Gen_Uleb128 (1);
+ Gen_Abbrev_Header (DW_TAG_Compile_Unit, DW_CHILDREN_Yes);
+
+ Gen_Abbrev_Tuple (DW_AT_Stmt_List, DW_FORM_Data4);
+ Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_Producer, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Comp_Dir, DW_FORM_String);
+ Gen_Abbrev_Tuple (0, 0);
+
+ Abbrev_Last := 1;
+
+ -- Info.
+ Create_Section (Info_Sect, ".debug_info", Section_Debug);
+ Set_Section_Info (Info_Sect, null, 0, 0);
+ Set_Current_Section (Info_Sect);
+ Info_Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Info_Sym, False);
+
+ Gen_32 (7); -- Length: to be patched.
+ Gen_16 (2); -- version
+ Gen_Ua_32 (Abbrev_Sym, 0); -- Abbrev offset
+ Gen_B8 (4); -- Ptr size.
+
+ -- Compile_unit.
+ Gen_Uleb128 (1);
+ Gen_Ua_32 (Line_Sym, 0);
+ Gen_Ua_32 (Orig_Sym, 0);
+ Gen_Ua_32 (End_Sym, 0);
+ Gen_String_Nul ("T.Gingold ortho_mcode (2004)");
+ Gen_String_Nul (GNAT.Directory_Operations.Get_Current_Dir);
+ end Init;
+
+ procedure Emit_Decl (Decl : O_Dnode);
+
+ -- Next node to be emitted.
+ Last_Decl : O_Dnode := O_Dnode_First;
+
+ procedure Emit_Decls_Until (Last : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ while Last_Decl < Last loop
+ Emit_Decl (Last_Decl);
+ Last_Decl := Get_Decl_Chain (Last_Decl);
+ end loop;
+ end Emit_Decls_Until;
+
+ procedure Finish
+ is
+ Length : Pc_Type;
+ Last : O_Dnode;
+ begin
+ Set_Symbol_Pc (End_Sym, False);
+ Length := Get_Current_Pc;
+
+ Last := Decls.Get_Decl_Last;
+ Emit_Decls_Until (Last);
+ if Last_Decl <= Last then
+ Emit_Decl (Last);
+ end if;
+
+ -- Finish abbrevs.
+ Set_Current_Section (Abbrev_Sect);
+ Gen_Uleb128 (0);
+
+ -- Emit header.
+ Set_Current_Section (Line_Sect);
+
+ -- Unit_Length (to be patched).
+ Gen_32 (0);
+ -- version
+ Gen_16 (2);
+ -- header_length (to be patched).
+ Gen_32 (5 + 12 + 1);
+ -- minimum_instruction_length.
+ Gen_B8 (Min_Insn_Len);
+ -- default_is_stmt
+ Gen_B8 (1);
+ -- line base
+ Gen_B8 (Line_Base);
+ -- line range
+ Gen_B8 (Line_Range);
+ -- opcode base
+ Gen_B8 (Line_Opcode_Base);
+ -- standard_opcode_length.
+ Gen_B8 (0); -- copy
+ Gen_B8 (1); -- advance pc
+ Gen_B8 (1); -- advance line
+ Gen_B8 (1); -- set file
+ Gen_B8 (1); -- set column
+ Gen_B8 (0); -- negate stmt
+ Gen_B8 (0); -- set basic block
+ Gen_B8 (0); -- const add pc
+ Gen_B8 (1); -- fixed advance pc
+ Gen_B8 (0); -- set prologue end
+ Gen_B8 (0); -- set epilogue begin
+ Gen_B8 (1); -- set isa
+ --if Line_Opcode_Base /= 13 then
+ -- raise Program_Error;
+ --end if;
+
+ -- include directories
+ declare
+ D : Dir_Chain_Acc;
+ begin
+ D := Dirs;
+ while D /= null loop
+ Gen_String_Nul (D.Name.all);
+ D := D.Next;
+ end loop;
+ Gen_B8 (0); -- last entry.
+ end;
+
+ -- file_names.
+ declare
+ F : File_Chain_Acc;
+ begin
+ F := Files;
+ while F /= null loop
+ Gen_String_Nul (F.Name.all);
+ Gen_Uleb128 (Unsigned_32 (F.Dir));
+ Gen_B8 (0); -- time
+ Gen_B8 (0); -- length
+ F := F.Next;
+ end loop;
+ Gen_B8 (0); -- last entry.
+ end;
+
+ -- Set prolog length
+ Patch_32 (6, Unsigned_32 (Get_Current_Pc - 6));
+
+ Merge_Section (Line_Sect, Line1_Sect);
+
+ -- Emit end of sequence.
+ Gen_B8 (0); -- extended opcode
+ Gen_B8 (1); -- length: 1
+ Gen_B8 (Byte (DW_LNE_End_Sequence));
+
+ -- Set total length.
+ Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4));
+
+ -- Info.
+ Set_Current_Section (Info_Sect);
+ -- Finish child.
+ Gen_Uleb128 (0);
+ -- Set total length.
+ Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4));
+
+ -- Aranges
+ Create_Section (Aranges_Sect, ".debug_aranges", Section_Debug);
+ Set_Section_Info (Aranges_Sect, null, 0, 0);
+ Set_Current_Section (Aranges_Sect);
+
+ Gen_32 (28); -- Length.
+ Gen_16 (2); -- version
+ Gen_Ua_32 (Info_Sym, 0); -- info offset
+ Gen_B8 (4); -- Ptr size.
+ Gen_B8 (0); -- seg desc size.
+ Gen_32 (0); -- pad
+ Gen_Ua_32 (Orig_Sym, 0); -- text offset
+ Gen_32 (Unsigned_32 (Length));
+ Gen_32 (0); -- End
+ Gen_32 (0);
+ end Finish;
+
+ procedure Generate_Abbrev (Abbrev : out Unsigned_32) is
+ begin
+ Abbrev_Last := Abbrev_Last + 1;
+ Abbrev := Abbrev_Last;
+
+ Set_Current_Section (Abbrev_Sect);
+ -- FIXME: should be enough ?
+ Prealloc (128);
+ Gen_Uleb128 (Abbrev);
+ end Generate_Abbrev;
+
+ procedure Gen_Info_Header (Abbrev : Unsigned_32) is
+ begin
+ Set_Current_Section (Info_Sect);
+ Gen_Uleb128 (Abbrev);
+ end Gen_Info_Header;
+
+ function Gen_Info_Sibling return Pc_Type
+ is
+ Pc : Pc_Type;
+ begin
+ Pc := Get_Current_Pc;
+ Gen_32 (0);
+ return Pc;
+ end Gen_Info_Sibling;
+
+ procedure Patch_Info_Sibling (Pc : Pc_Type) is
+ begin
+ Patch_32 (Pc, Unsigned_32 (Get_Current_Pc));
+ end Patch_Info_Sibling;
+
+ Abbrev_Base_Type : Unsigned_32 := 0;
+ Abbrev_Base_Type_Name : Unsigned_32 := 0;
+ Abbrev_Pointer : Unsigned_32 := 0;
+ Abbrev_Pointer_Name : Unsigned_32 := 0;
+ Abbrev_Uncomplete_Pointer : Unsigned_32 := 0;
+ Abbrev_Uncomplete_Pointer_Name : Unsigned_32 := 0;
+ Abbrev_Ucarray : Unsigned_32 := 0;
+ Abbrev_Ucarray_Name : Unsigned_32 := 0;
+ Abbrev_Uc_Subrange : Unsigned_32 := 0;
+ Abbrev_Subarray : Unsigned_32 := 0;
+ Abbrev_Subarray_Name : Unsigned_32 := 0;
+ Abbrev_Subrange : Unsigned_32 := 0;
+ Abbrev_Struct : Unsigned_32 := 0;
+ Abbrev_Struct_Name : Unsigned_32 := 0;
+ Abbrev_Union : Unsigned_32 := 0;
+ Abbrev_Union_Name : Unsigned_32 := 0;
+ Abbrev_Member : Unsigned_32 := 0;
+ Abbrev_Enum : Unsigned_32 := 0;
+ Abbrev_Enum_Name : Unsigned_32 := 0;
+ Abbrev_Enumerator : Unsigned_32 := 0;
+
+ package TOnodes is new GNAT.Table
+ (Table_Component_Type => Pc_Type,
+ Table_Index_Type => O_Tnode,
+ Table_Low_Bound => O_Tnode_First,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ procedure Emit_Type_Ref (Atype : O_Tnode)
+ is
+ Off : Pc_Type;
+ begin
+ Off := TOnodes.Table (Atype);
+ if Off = Null_Pc then
+ raise Program_Error;
+ end if;
+ Gen_32 (Unsigned_32 (Off));
+ end Emit_Type_Ref;
+
+ procedure Emit_Ident (Id : O_Ident)
+ is
+ use Ortho_Ident;
+ L : Natural;
+ begin
+ L := Get_String_Length (Id);
+ Prealloc (Pc_Type (L) + 128);
+ Gen_String_Nul (Get_String (Id));
+ end Emit_Ident;
+
+ procedure Add_Type_Ref (Atype : O_Tnode; Pc : Pc_Type)
+ is
+ Prev : O_Tnode;
+ begin
+ if Atype > TOnodes.Last then
+ -- Expand.
+ Prev := TOnodes.Last;
+ TOnodes.Set_Last (Atype);
+ TOnodes.Table (Prev + 1 .. Atype - 1) := (others => Null_Pc);
+ end if;
+ TOnodes.Table (Atype) := Pc;
+ end Add_Type_Ref;
+
+ procedure Emit_Decl_Ident (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ Emit_Ident (Get_Decl_Ident (Decl));
+ end Emit_Decl_Ident;
+
+ procedure Emit_Decl_Ident_If_Set (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ if Decl /= O_Dnode_Null then
+ Emit_Ident (Get_Decl_Ident (Decl));
+ end if;
+ end Emit_Decl_Ident_If_Set;
+
+ procedure Emit_Type (Atype : O_Tnode);
+
+ procedure Emit_Base_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Encoding, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Base_Type = 0 then
+ Generate_Abbrev (Abbrev_Base_Type);
+ Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Base_Type);
+ else
+ if Abbrev_Base_Type_Name = 0 then
+ Generate_Abbrev (Abbrev_Base_Type_Name);
+ Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Base_Type_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+
+ case Get_Type_Kind (Atype) is
+ when OT_Signed =>
+ Gen_B8 (DW_ATE_Signed);
+ when OT_Unsigned =>
+ Gen_B8 (DW_ATE_Unsigned);
+ when OT_Float =>
+ Gen_B8 (DW_ATE_Float);
+ when others =>
+ raise Program_Error;
+ end case;
+ Gen_B8 (Byte (Get_Type_Size (Atype)));
+ end Emit_Base_Type;
+
+ procedure Emit_Access_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+
+ procedure Finish_Gen_Abbrev_Uncomplete is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev_Uncomplete;
+
+ Dtype : O_Tnode;
+ D_Pc : Pc_Type;
+ begin
+ Dtype := Get_Type_Access_Type (Atype);
+
+ if Dtype = O_Tnode_Null then
+ if Decl = O_Dnode_Null then
+ if Abbrev_Uncomplete_Pointer = 0 then
+ Generate_Abbrev (Abbrev_Uncomplete_Pointer);
+ Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+ Finish_Gen_Abbrev_Uncomplete;
+ end if;
+ Gen_Info_Header (Abbrev_Uncomplete_Pointer);
+ else
+ if Abbrev_Uncomplete_Pointer_Name = 0 then
+ Generate_Abbrev (Abbrev_Uncomplete_Pointer_Name);
+ Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev_Uncomplete;
+ end if;
+ Gen_Info_Header (Abbrev_Uncomplete_Pointer_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+ Gen_B8 (Byte (Get_Type_Size (Atype)));
+ else
+ if Decl = O_Dnode_Null then
+ if Abbrev_Pointer = 0 then
+ Generate_Abbrev (Abbrev_Pointer);
+ Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Pointer);
+ else
+ if Abbrev_Pointer_Name = 0 then
+ Generate_Abbrev (Abbrev_Pointer_Name);
+ Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Pointer_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+ Gen_B8 (Byte (Get_Type_Size (Atype)));
+ -- Break possible loops: generate the access entry...
+ D_Pc := Get_Current_Pc;
+ Gen_32 (0);
+ -- ... generate the designated type ...
+ Emit_Type (Dtype);
+ -- ... and write its reference.
+ Patch_32 (D_Pc, Unsigned_32 (TOnodes.Table (Dtype)));
+ end if;
+ end Emit_Access_Type;
+
+ procedure Emit_Ucarray_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Ucarray = 0 then
+ Generate_Abbrev (Abbrev_Ucarray);
+ Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Ucarray);
+ else
+ if Abbrev_Ucarray_Name = 0 then
+ Generate_Abbrev (Abbrev_Ucarray_Name);
+ Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Ucarray_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+ Emit_Type_Ref (Get_Type_Ucarray_Element (Atype));
+
+ if Abbrev_Uc_Subrange = 0 then
+ Generate_Abbrev (Abbrev_Uc_Subrange);
+ Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Gen_Info_Header (Abbrev_Uc_Subrange);
+ Emit_Type_Ref (Get_Type_Ucarray_Index (Atype));
+
+ Gen_Uleb128 (0);
+ end Emit_Ucarray_Type;
+
+ procedure Emit_Subarray_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+
+ Base : O_Tnode;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Subarray = 0 then
+ Generate_Abbrev (Abbrev_Subarray);
+ Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Subarray);
+ else
+ if Abbrev_Subarray_Name = 0 then
+ Generate_Abbrev (Abbrev_Subarray_Name);
+ Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Subarray_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+
+ Base := Get_Type_Subarray_Base (Atype);
+
+ Emit_Type_Ref (Get_Type_Ucarray_Element (Base));
+ Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype)));
+
+ if Abbrev_Subrange = 0 then
+ Generate_Abbrev (Abbrev_Subrange);
+ Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Lower_Bound, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (DW_AT_Count, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Gen_Info_Header (Abbrev_Subrange);
+ Emit_Type_Ref (Get_Type_Ucarray_Index (Base));
+ Gen_B8 (0);
+ Gen_Uleb128 (Unsigned_32 (Get_Type_Subarray_Length (Atype)));
+
+ Gen_Uleb128 (0);
+ end Emit_Subarray_Type;
+
+ procedure Emit_Members (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ Nbr : Uns32;
+ F : O_Fnode;
+ Loc_Pc : Pc_Type;
+ Sibling_Pc : Pc_Type;
+ begin
+ if Abbrev_Member = 0 then
+ Generate_Abbrev (Abbrev_Member);
+
+ Gen_Abbrev_Header (DW_TAG_Member, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Data_Member_Location, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Set_Current_Section (Info_Sect);
+ Sibling_Pc := Gen_Info_Sibling;
+ Emit_Decl_Ident_If_Set (Decl);
+ Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype)));
+
+ Nbr := Get_Type_Record_Nbr_Fields (Atype);
+ F := Get_Type_Record_Fields (Atype);
+ while Nbr > 0 loop
+ Gen_Uleb128 (Abbrev_Member);
+ Emit_Ident (Get_Field_Ident (F));
+ Emit_Type_Ref (Get_Field_Type (F));
+
+ -- Location.
+ Loc_Pc := Get_Current_Pc;
+ Gen_B8 (3);
+ Gen_B8 (DW_OP_Plus_Uconst);
+ Gen_Uleb128 (Unsigned_32 (Get_Field_Offset (F)));
+ Patch_B8 (Loc_Pc, Unsigned_8 (Get_Current_Pc - (Loc_Pc + 1)));
+
+ F := Get_Field_Chain (F);
+ Nbr := Nbr - 1;
+ end loop;
+
+ -- end of children.
+ Gen_Uleb128 (0);
+ Patch_Info_Sibling (Sibling_Pc);
+ end Emit_Members;
+
+ procedure Emit_Record_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Struct = 0 then
+ Generate_Abbrev (Abbrev_Struct);
+
+ Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Struct);
+ else
+ if Abbrev_Struct_Name = 0 then
+ Generate_Abbrev (Abbrev_Struct_Name);
+
+ Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Struct_Name);
+ end if;
+ Emit_Members (Atype, Decl);
+ end Emit_Record_Type;
+
+ procedure Emit_Union_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Union = 0 then
+ Generate_Abbrev (Abbrev_Union);
+
+ Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Union);
+ else
+ if Abbrev_Union_Name = 0 then
+ Generate_Abbrev (Abbrev_Union_Name);
+
+ Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Union_Name);
+ end if;
+ Emit_Members (Atype, Decl);
+ end Emit_Union_Type;
+
+ procedure Emit_Enum_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ use Ortho_Code.Consts;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+
+ procedure Emit_Enumerator (L : O_Cnode) is
+ begin
+ Gen_Uleb128 (Abbrev_Enumerator);
+ Emit_Ident (Get_Lit_Ident (L));
+ Gen_Uleb128 (Unsigned_32 (Get_Lit_Value (L)));
+ end Emit_Enumerator;
+
+ Nbr : Uns32;
+ L : O_Cnode;
+ Sibling_Pc : Pc_Type;
+ begin
+ if Abbrev_Enumerator = 0 then
+ Generate_Abbrev (Abbrev_Enumerator);
+
+ Gen_Abbrev_Header (DW_TAG_Enumerator, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Const_Value, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+ if Decl = O_Dnode_Null then
+ if Abbrev_Enum = 0 then
+ Generate_Abbrev (Abbrev_Enum);
+ Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Enum);
+ else
+ if Abbrev_Enum_Name = 0 then
+ Generate_Abbrev (Abbrev_Enum_Name);
+ Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Enum_Name);
+ end if;
+
+ Sibling_Pc := Gen_Info_Sibling;
+ Emit_Decl_Ident_If_Set (Decl);
+ Gen_B8 (Byte (Get_Type_Size (Atype)));
+ case Get_Type_Kind (Atype) is
+ when OT_Enum =>
+ Nbr := Get_Type_Enum_Nbr_Lits (Atype);
+ L := Get_Type_Enum_Lits (Atype);
+ while Nbr > 0 loop
+ Emit_Enumerator (L);
+
+ L := Get_Lit_Chain (L);
+ Nbr := Nbr - 1;
+ end loop;
+ when OT_Boolean =>
+ Emit_Enumerator (Get_Type_Bool_False (Atype));
+ Emit_Enumerator (Get_Type_Bool_True (Atype));
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- End of children.
+ Gen_Uleb128 (0);
+ Patch_Info_Sibling (Sibling_Pc);
+ end Emit_Enum_Type;
+
+ procedure Emit_Type (Atype : O_Tnode)
+ is
+ use Ortho_Code.Types;
+ use Ada.Text_IO;
+ Kind : OT_Kind;
+ Decl : O_Dnode;
+ begin
+ -- If already emitted, then return.
+ if Atype <= TOnodes.Last
+ and then TOnodes.Table (Atype) /= Null_Pc
+ then
+ return;
+ end if;
+
+ Kind := Get_Type_Kind (Atype);
+
+ -- First step: emit inner types (if any).
+ case Kind is
+ when OT_Signed
+ | OT_Unsigned
+ | OT_Float
+ | OT_Boolean
+ | OT_Enum =>
+ null;
+ when OT_Access =>
+ null;
+ when OT_Ucarray =>
+ Emit_Type (Get_Type_Ucarray_Index (Atype));
+ Emit_Type (Get_Type_Ucarray_Element (Atype));
+ when OT_Subarray =>
+ Emit_Type (Get_Type_Subarray_Base (Atype));
+ when OT_Record
+ | OT_Union =>
+ declare
+ Nbr : Uns32;
+ F : O_Fnode;
+ begin
+ Nbr := Get_Type_Record_Nbr_Fields (Atype);
+ F := Get_Type_Record_Fields (Atype);
+ while Nbr > 0 loop
+ Emit_Type (Get_Field_Type (F));
+ F := Get_Field_Chain (F);
+ Nbr := Nbr - 1;
+ end loop;
+ end;
+ when OT_Complete =>
+ null;
+ end case;
+
+ Set_Current_Section (Info_Sect);
+ Add_Type_Ref (Atype, Get_Current_Pc);
+
+ Decl := Decls.Get_Type_Decl (Atype);
+
+ -- Second step: emit info.
+ case Kind is
+ when OT_Signed
+ | OT_Unsigned
+ | OT_Float =>
+ Emit_Base_Type (Atype, Decl);
+ -- base types.
+ when OT_Access =>
+ Emit_Access_Type (Atype, Decl);
+ when OT_Ucarray =>
+ Emit_Ucarray_Type (Atype, Decl);
+ when OT_Subarray =>
+ Emit_Subarray_Type (Atype, Decl);
+ when OT_Record =>
+ Emit_Record_Type (Atype, Decl);
+ when OT_Union =>
+ Emit_Union_Type (Atype, Decl);
+ when OT_Enum
+ | OT_Boolean =>
+ Emit_Enum_Type (Atype, Decl);
+ when OT_Complete =>
+ null;
+ end case;
+ end Emit_Type;
+
+ procedure Emit_Decl_Type (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ Emit_Type_Ref (Get_Decl_Type (Decl));
+ end Emit_Decl_Type;
+
+ Abbrev_Variable : Unsigned_32 := 0;
+ Abbrev_Const : Unsigned_32 := 0;
+
+ procedure Emit_Local_Location (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Pc : Pc_Type;
+ begin
+ Pc := Get_Current_Pc;
+ Gen_B8 (2);
+ Gen_B8 (DW_OP_Fbreg);
+ Gen_Sleb128 (Get_Decl_Info (Decl));
+ Patch_B8 (Pc, Unsigned_8 (Get_Current_Pc - (Pc + 1)));
+ end Emit_Local_Location;
+
+ procedure Emit_Global_Location (Decl : O_Dnode)
+ is
+ use Ortho_Code.Binary;
+ begin
+ Gen_B8 (5);
+ Gen_B8 (DW_OP_Addr);
+ Gen_Ua_32 (Get_Decl_Symbol (Decl), 0);
+ end Emit_Global_Location;
+
+ procedure Emit_Variable (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Dtype : O_Tnode;
+ begin
+ if Get_Decl_Ident (Decl) = O_Ident_Nul then
+ return;
+ end if;
+
+ if Abbrev_Variable = 0 then
+ Generate_Abbrev (Abbrev_Variable);
+ Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Dtype := Get_Decl_Type (Decl);
+ Emit_Type (Dtype);
+
+ Gen_Info_Header (Abbrev_Variable);
+ Emit_Decl_Ident (Decl);
+ Emit_Type_Ref (Dtype);
+ case Get_Decl_Kind (Decl) is
+ when OD_Local =>
+ Emit_Local_Location (Decl);
+ when OD_Var =>
+ Emit_Global_Location (Decl);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Emit_Variable;
+
+ procedure Emit_Const (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Dtype : O_Tnode;
+ begin
+ if Abbrev_Const = 0 then
+ Generate_Abbrev (Abbrev_Const);
+ -- FIXME: should be a TAG_Constant, however, GDB does not support it.
+ -- work-around: could use a const_type.
+ Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Dtype := Get_Decl_Type (Decl);
+ Emit_Type (Dtype);
+ Gen_Info_Header (Abbrev_Const);
+ Emit_Decl_Ident (Decl);
+ Emit_Type_Ref (Dtype);
+ Emit_Global_Location (Decl);
+ end Emit_Const;
+
+ procedure Emit_Type_Decl (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ Emit_Type (Get_Decl_Type (Decl));
+ end Emit_Type_Decl;
+
+ Subprg_Sym : Symbol;
+
+ Abbrev_Block : Unsigned_32 := 0;
+
+ procedure Emit_Block_Decl (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Last : O_Dnode;
+ Sdecl : O_Dnode;
+ Sibling_Pc : Pc_Type;
+ begin
+ if Abbrev_Block = 0 then
+ Generate_Abbrev (Abbrev_Block);
+
+ Gen_Abbrev_Header (DW_TAG_Lexical_Block, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Gen_Info_Header (Abbrev_Block);
+ Sibling_Pc := Gen_Info_Sibling;
+
+ Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl)));
+ Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl)));
+
+ -- Emit decls for children.
+ Last := Get_Block_Last (Decl);
+ Sdecl := Decl + 1;
+ while Sdecl <= Last loop
+ Emit_Decl (Sdecl);
+ Sdecl := Get_Decl_Chain (Sdecl);
+ end loop;
+
+ -- End of children.
+ Set_Current_Section (Info_Sect);
+ Gen_Uleb128 (0);
+
+ Patch_Info_Sibling (Sibling_Pc);
+ end Emit_Block_Decl;
+
+ Abbrev_Function : Unsigned_32 := 0;
+ Abbrev_Procedure : Unsigned_32 := 0;
+ Abbrev_Interface : Unsigned_32 := 0;
+
+ procedure Emit_Subprg_Body (Bod : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Kind : OD_Kind;
+ Decl : O_Dnode;
+ Idecl : O_Dnode;
+ Prev_Subprg_Sym : Symbol;
+ Sibling_Pc : Pc_Type;
+ begin
+ Decl := Get_Body_Decl (Bod);
+ Kind := Get_Decl_Kind (Decl);
+
+ -- Emit interfaces type.
+ Idecl := Get_Subprg_Interfaces (Decl);
+ while Idecl /= O_Dnode_Null loop
+ Emit_Type (Get_Decl_Type (Idecl));
+ Idecl := Get_Interface_Chain (Idecl);
+ end loop;
+
+ if Kind = OD_Function then
+ Emit_Type (Get_Decl_Type (Decl));
+ if Abbrev_Function = 0 then
+ Generate_Abbrev (Abbrev_Function);
+
+ Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1);
+ --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+ Gen_Info_Header (Abbrev_Function);
+ else
+ if Abbrev_Procedure = 0 then
+ Generate_Abbrev (Abbrev_Procedure);
+
+ Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1);
+ --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+ Gen_Info_Header (Abbrev_Procedure);
+ end if;
+
+ Sibling_Pc := Gen_Info_Sibling;
+
+ if Kind = OD_Function then
+ Emit_Decl_Type (Decl);
+ end if;
+
+ Emit_Decl_Ident (Decl);
+ Prev_Subprg_Sym := Subprg_Sym;
+ Subprg_Sym := Binary.Get_Decl_Symbol (Decl);
+ Gen_Ua_32 (Subprg_Sym, 0);
+ Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Body_Info (Bod)));
+
+ -- Frame base.
+ Gen_B8 (1);
+ Gen_B8 (DW_OP_Reg5);
+
+ -- Interfaces.
+ Idecl := Get_Subprg_Interfaces (Decl);
+ if Idecl /= O_Dnode_Null then
+ if Abbrev_Interface = 0 then
+ Generate_Abbrev (Abbrev_Interface);
+
+ Gen_Abbrev_Header (DW_TAG_Formal_Parameter, DW_CHILDREN_No);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ loop
+ Gen_Info_Header (Abbrev_Interface);
+ Emit_Decl_Type (Idecl);
+ Emit_Decl_Ident (Idecl);
+
+ Emit_Local_Location (Idecl);
+
+ Idecl := Get_Interface_Chain (Idecl);
+ exit when Idecl = O_Dnode_Null;
+ end loop;
+ end if;
+
+ -- Internal declarations.
+ Emit_Block_Decl (Bod + 1);
+
+ -- End of children.
+ Gen_Uleb128 (0);
+
+ Patch_Info_Sibling (Sibling_Pc);
+
+ Subprg_Sym := Prev_Subprg_Sym;
+ end Emit_Subprg_Body;
+
+ procedure Emit_Decl (Decl : O_Dnode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Decls;
+ begin
+ case Get_Decl_Kind (Decl) is
+ when OD_Type =>
+ Emit_Type_Decl (Decl);
+ when OD_Local
+ | OD_Var =>
+ Emit_Variable (Decl);
+ when OD_Const =>
+ Emit_Const (Decl);
+ when OD_Function
+ | OD_Procedure
+ | OD_Interface =>
+ null;
+ when OD_Body =>
+ Emit_Subprg_Body (Decl);
+ when OD_Block =>
+ Emit_Block_Decl (Decl);
+ when others =>
+ Put_Line ("dwarf.emit_decl: emit "
+ & OD_Kind'Image (Get_Decl_Kind (Decl)));
+ end case;
+ end Emit_Decl;
+
+ procedure Emit_Subprg (Bod : O_Dnode) is
+ begin
+ Emit_Decls_Until (Bod);
+ Emit_Decl (Bod);
+ Last_Decl := Decls.Get_Decl_Chain (Bod);
+ end Emit_Subprg;
+
+ procedure Mark (M : out Mark_Type) is
+ begin
+ M.Last_Decl := Last_Decl;
+ M.Last_Tnode := TOnodes.Last;
+ end Mark;
+
+ procedure Release (M : Mark_Type) is
+ begin
+ Last_Decl := M.Last_Decl;
+ TOnodes.Set_Last (M.Last_Tnode);
+ end Release;
+
+end Ortho_Code.Dwarf;
+
diff --git a/src/ortho/mcode/ortho_code-dwarf.ads b/src/ortho/mcode/ortho_code-dwarf.ads
new file mode 100644
index 000000000..c120bcfe1
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-dwarf.ads
@@ -0,0 +1,41 @@
+-- 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);
+
+ -- Emit all debug info until but not including LAST.
+ procedure Emit_Decls_Until (Last : 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/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb
new file mode 100644
index 000000000..b2dfa1a67
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-exprs.adb
@@ -0,0 +1,1663 @@
+-- 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; use 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_Stack_Adjust (Enode : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Enode).Arg1);
+ end Get_Stack_Adjust;
+
+ 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;
+ pragma Unreferenced (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;
+
+ function Get_Loop_Level (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg1);
+ end Get_Loop_Level;
+
+ procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32) is
+ begin
+ Enodes.Table (Stmt).Arg1 := O_Enode (Level);
+ end Set_Loop_Level;
+
+ 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 : constant 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_Union
+ | OC_Sizeof
+ | OC_Alignof =>
+ 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
+ -- The static chain is the first interface of the subprogram.
+ Res := New_Enode (OE_Addrl, Abi.Mode_Ptr, O_Tnode_Ptr,
+ O_Enode (Get_Subprg_Interfaces (Subprg.D_Decl)),
+ 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;
+ if Get_Base_Type (Get_Enode_Type (O_Enode (Lvalue)))
+ /= Get_Base_Type (Get_Type_Access_Type (Atype))
+ 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;
+ St_Type : O_Tnode;
+ 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);
+ if Stack_Ptr_Type /= O_Tnode_Null then
+ St_Type := Stack_Ptr_Type;
+ else
+ St_Type := Rtype;
+ end if;
+ -- Add a decl.
+ New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, St_Type);
+ -- Add insn to save stack ptr.
+ Stmt := New_Enode (OE_Asgn, St_Type,
+ New_Stack (St_Type),
+ 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 not Flag_Lower_Stmt 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_Else_Stmt (Block : in out O_If_Block) is
+ begin
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_Else, 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 not Flag_Lower_Stmt 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 not Flag_Lower_Stmt 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 not Flag_Lower_Stmt 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 not Flag_Lower_Stmt 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 not Flag_Lower_Stmt 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 Debug_Expr (N : O_Enode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Debug.Int32_IO;
+ Indent : constant Count := Col;
+ begin
+ Put (Int32 (N), 0);
+ Set_Col (Indent + 7);
+ Disp_Mode (Get_Expr_Mode (N));
+ Put (" ");
+ Put (OE_Kind'Image (Get_Expr_Kind (N)));
+ Set_Col (Indent + 28);
+-- 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 Debug_Expr;
+
+ procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode)
+ is
+ use Ada.Text_IO;
+ 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.
+ Set_Col (Count (Indent));
+ Debug_Expr (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 =>
+ Set_Col (Count (Indent));
+ Debug_Expr (N);
+ exit;
+ when others =>
+ Set_Col (Count (N_Indent));
+ Debug_Expr (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
+ Debug_Expr (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/src/ortho/mcode/ortho_code-exprs.ads b/src/ortho/mcode/ortho_code-exprs.ads
new file mode 100644
index 000000000..9bd4596d7
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-exprs.ads
@@ -0,0 +1,600 @@
+-- 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,
+
+ -- Modify the stack pointer value, to align the stack before pushing
+ -- arguments, or to free the stack.
+ -- ARG1 is the signed offset.
+ OE_Stack_Adjust,
+
+ -- 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 else/endif
+ OE_If,
+ OE_Else,
+ OE_Endif,
+
+ -- ARG1: loop level.
+ OE_Loop,
+ -- ARG1: 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;
+
+ -- Type of the stack pointer - for OE_Get_Stack and OE_Set_Stack.
+ -- Can be set by back-ends.
+ Stack_Ptr_Type : O_Tnode := O_Tnode_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/OE_Alloca
+ -- 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);
+
+ -- Return the stack adjustment. For positive values, this is the amount of
+ -- bytes to allocate on the stack before pushing arguments, so that the
+ -- stack pointer stays aligned. For negtive values, this is the amount of
+ -- bytes to release on the stack.
+ function Get_Stack_Adjust (Enode : O_Enode) return Int32;
+
+ -- 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;
+
+ -- For OE_Loop, set loop level (an integer).
+ -- Reserved for back-end in HLI mode only.
+ function Get_Loop_Level (Stmt : O_Enode) return Int32;
+ procedure Set_Loop_Level (Stmt : O_Enode; Level : 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);
+ 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/src/ortho/mcode/ortho_code-flags.ads b/src/ortho/mcode/ortho_code-flags.ads
new file mode 100644
index 000000000..805f3779b
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-opts.adb b/src/ortho/mcode/ortho_code-opts.adb
new file mode 100644
index 000000000..0ea6b039b
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-opts.adb
@@ -0,0 +1,214 @@
+-- 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;
+ pragma Unreferenced (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 := True;
+ 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/src/ortho/mcode/ortho_code-opts.ads b/src/ortho/mcode/ortho_code-opts.ads
new file mode 100644
index 000000000..27a907c7b
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-types.adb b/src/ortho/mcode/ortho_code-types.adb
new file mode 100644
index 000000000..e0c070c27
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-types.adb
@@ -0,0 +1,820 @@
+-- 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 Ortho_Code.Consts; use Ortho_Code.Consts;
+with Ortho_Code.Debug;
+with Ortho_Code.Abi; use Ortho_Code.Abi;
+with Ortho_Ident;
+
+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.
+ Deferred : Boolean; -- 1 bit (True if the type was incomplete at first)
+ Flag1 : Boolean;
+ Pad0 : Bool_Array (0 .. 19);
+ Size : Uns32;
+ end record;
+ pragma Pack (Tnode_Common);
+ for Tnode_Common'Size use 64;
+
+ 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
+ Parent : O_Tnode;
+ 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_Bytes (Atype : O_Tnode) return Uns32 is
+ begin
+ return 2 ** Get_Type_Align (Atype);
+ end Get_Type_Align_Bytes;
+
+ function Get_Type_Mode (Atype : O_Tnode) return Mode_Type is
+ begin
+ return Tnodes.Table (Atype).Mode;
+ end Get_Type_Mode;
+
+ function Get_Type_Deferred (Atype : O_Tnode) return Boolean is
+ begin
+ return Tnodes.Table (Atype).Deferred;
+ end Get_Type_Deferred;
+
+ function Get_Type_Flag1 (Atype : O_Tnode) return Boolean is
+ begin
+ return Tnodes.Table (Atype).Flag1;
+ end Get_Type_Flag1;
+
+ procedure Set_Type_Flag1 (Atype : O_Tnode; Flag : Boolean) is
+ begin
+ Tnodes.Table (Atype).Flag1 := Flag;
+ end Set_Type_Flag1;
+
+ 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;
+
+ procedure Set_Field_Offset (Field : O_Fnode; Offset : Uns32) is
+ begin
+ Fnodes.Table (Field).Offset := Offset;
+ end Set_Field_Offset;
+
+ function Get_Field_Parent (Field : O_Fnode) return O_Tnode is
+ begin
+ return Fnodes.Table (Field).Parent;
+ end Get_Field_Parent;
+
+ 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 Fnodes.Table (Field).Next;
+ 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),
+ Deferred => False,
+ Flag1 => False,
+ 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),
+ Deferred => False,
+ Flag1 => False,
+ 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),
+ Deferred => False,
+ Flag1 => False,
+ 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),
+ Deferred => False,
+ Flag1 => False,
+ 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,
+ Deferred => False,
+ Flag1 => False,
+ 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),
+ Deferred => False,
+ Flag1 => False,
+ 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),
+ Deferred => False,
+ Flag1 => False,
+ 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;
+
+ procedure Create_Completer (Atype : O_Tnode) is
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Complete,
+ Mode => Mode_Nil,
+ Align => 0,
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => To_Uns32 (Int32 (Atype))));
+ end Create_Completer;
+
+ function Get_Type_Complete_Type (Atype : O_Tnode) return O_Tnode is
+ begin
+ return O_Tnode (To_Int32 (Tnodes.Table (Atype).Size));
+ end Get_Type_Complete_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),
+ Deferred => Dtype = O_Tnode_Null,
+ Flag1 => False,
+ 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));
+ if Flag_Type_Completer then
+ Create_Completer (Atype);
+ end if;
+ end Finish_Access_Type;
+
+
+ function To_Tnode_Common is new Ada.Unchecked_Conversion
+ (Source => Tnode_Record, Target => Tnode_Common);
+
+ function Create_Record_Type (Deferred : Boolean) return O_Tnode
+ is
+ Res : O_Tnode;
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Record,
+ Mode => Mode_Blk,
+ Align => 0,
+ Deferred => Deferred,
+ Flag1 => False,
+ 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 (False),
+ 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 (True);
+ 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 : constant Uns32 := Get_Type_Align_Bytes (Atype) - 1;
+ begin
+ -- Align.
+ return (Off + Msk) and (not Msk);
+ end Do_Align;
+
+ function Do_Align (Off : Uns32; Mode : Mode_Type) return Uns32
+ is
+ Msk : constant Uns32 := (2 ** Mode_Align (Mode)) - 1;
+ begin
+ -- Align.
+ 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'(Parent => Elements.Res,
+ 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;
+ if Flag_Type_Completer
+ and then Tnodes.Table (Elements.Res).Deferred
+ then
+ Create_Completer (Elements.Res);
+ end if;
+ 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,
+ Deferred => False,
+ Flag1 => False,
+ 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 Debug_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)));
+ Put (" D=");
+ Put (Boolean'Image (Get_Type_Deferred (Atype)));
+ Put (" F1=");
+ Put (Boolean'Image (Get_Type_Flag1 (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 OT_Access =>
+ Put (" acc_type: ");
+ Put (Int32 (Get_Type_Access_Type (Atype)));
+ New_Line;
+ when OT_Record =>
+ Put (" fields: ");
+ Put (Int32 (Get_Type_Record_Fields (Atype)));
+ Put (", nbr_fields: ");
+ Put (To_Int32 (Get_Type_Record_Nbr_Fields (Atype)));
+ New_Line;
+ when OT_Subarray =>
+ Put (" base type: ");
+ Put (Int32 (Get_Type_Subarray_Base (Atype)));
+ Put (", length: ");
+ Put (To_Int32 (Get_Type_Subarray_Length (Atype)));
+ New_Line;
+ when others =>
+ null;
+ end case;
+ end Debug_Type;
+
+ procedure Debug_Field (Field : O_Fnode)
+ is
+ use Ortho_Code.Debug.Int32_IO;
+ use Ada.Text_IO;
+ begin
+ Put (Int32 (Field), 3);
+ Put (" ");
+ Put (" Offset=");
+ Put (To_Int32 (Get_Field_Offset (Field)), 0);
+ Put (", Ident=");
+ Put (Ortho_Ident.Get_String (Get_Field_Ident (Field)));
+ Put (", Type=");
+ Put (Int32 (Get_Field_Type (Field)), 0);
+ Put (", Chain=");
+ Put (Int32 (Get_Field_Chain (Field)), 0);
+ New_Line;
+ end Debug_Field;
+
+ function Get_Type_Limit return O_Tnode is
+ begin
+ return Tnodes.Last;
+ end Get_Type_Limit;
+
+ function Get_Type_Next (Atype : O_Tnode) return O_Tnode is
+ begin
+ case Tnodes.Table (Atype).Kind is
+ when OT_Unsigned
+ | OT_Signed
+ | OT_Float =>
+ return Atype + 1;
+ when OT_Boolean
+ | OT_Enum
+ | OT_Ucarray
+ | OT_Subarray
+ | OT_Access
+ | OT_Record
+ | OT_Union =>
+ return Atype + 2;
+ when OT_Complete =>
+ return Atype + 1;
+ end case;
+ end Get_Type_Next;
+
+ function Get_Base_Type (Atype : O_Tnode) return O_Tnode
+ is
+ begin
+ case Get_Type_Kind (Atype) is
+ when OT_Subarray =>
+ return Get_Type_Subarray_Base (Atype);
+ when others =>
+ return Atype;
+ end case;
+ end Get_Base_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/src/ortho/mcode/ortho_code-types.ads b/src/ortho/mcode/ortho_code-types.ads
new file mode 100644
index 000000000..da6549841
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-types.ads
@@ -0,0 +1,240 @@
+-- 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,
+
+ -- Type completion. Mark the completion of a type.
+ -- Optionnal.
+ OT_Complete);
+
+ -- 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;
+
+ -- Alignment for ATYPE in bytes.
+ function Get_Type_Align_Bytes (Atype : O_Tnode) return Uns32;
+
+ -- Return true is the type was incomplete at creation.
+ -- (it may - or not - have been completed later).
+ function Get_Type_Deferred (Atype : O_Tnode) return Boolean;
+
+ -- A back-end reserved flag.
+ -- Initialized to False.
+ function Get_Type_Flag1 (Atype : O_Tnode) return Boolean;
+ procedure Set_Type_Flag1 (Atype : O_Tnode; Flag : Boolean);
+
+ -- 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;
+
+ -- Return the union/record type which contains FIELD.
+ function Get_Field_Parent (Field : O_Fnode) return O_Tnode;
+
+ -- Get the offset of FIELD in its record/union.
+ function Get_Field_Offset (Field : O_Fnode) return Uns32;
+ procedure Set_Field_Offset (Field : O_Fnode; Offset : 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;
+
+ -- Get the type that was completed.
+ function Get_Type_Complete_Type (Atype : O_Tnode) return O_Tnode;
+
+ -- 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;
+
+ -- Return the base type of ATYPE: for a subarray this is the uc array,
+ -- otherwise this is the type.
+ function Get_Base_Type (Atype : O_Tnode) 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;
+
+ -- Get a type number limit (an O_Tnode is a number).
+ -- There is no type whose number is beyond this limit.
+ -- Note: the limit may not be a type!
+ function Get_Type_Limit return O_Tnode;
+
+ -- Get the type which follows ATYPE.
+ -- User has to check that the result is valid (ie not beyond limit).
+ function Get_Type_Next (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);
+
+ procedure Debug_Type (Atype : O_Tnode);
+ procedure Debug_Field (Field : O_Fnode);
+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/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb
new file mode 100644
index 000000000..bb06d51d4
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-abi.adb
@@ -0,0 +1,762 @@
+-- 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.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 Ortho_Code.X86.Flags;
+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
+ -- First argument is at %ebp + 8
+ 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))));
+ -- Offset is 8 biased.
+ 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);
+ 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);
+
+ if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel
+ and then Flag_Debug = Debug_Dwarf
+ then
+ Dwarf.Emit_Decls_Until (Subprg.D_Body);
+ if not Debug.Flag_Debug_Keep then
+ Dwarf.Mark (Dwarf_Mark);
+ end if;
+ end if;
+
+ -- 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 : constant O_Dnode := Get_Addr_Object (Stmt);
+ Frame : constant 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
+ | Regs_Xmm =>
+ 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_Stack_Adjust =>
+ Put (" stack_adjust: ");
+ Put (Int32'Image (Get_Stack_Adjust (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;
+
+ Stmt : O_Enode;
+ begin
+ Disp_Subprg_Decl (Get_Body_Decl (Subprg));
+
+ Stmt := Get_Body_Stmt (Subprg);
+ 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
+ -- Alignment of doubles is platform dependent.
+ Mode_Align (Mode_F64) := X86.Flags.Mode_F64_Align;
+
+ 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 R_Xmm0 =>
+ return "xmm0";
+ when R_Xmm1 =>
+ return "xmm1";
+ when R_Xmm2 =>
+ return "xmm2";
+ when R_Xmm3 =>
+ return "xmm3";
+ 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 Chkstk (Sz : Integer);
+ pragma Import (C, Chkstk, "__chkstk");
+
+ 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);
+ if X86.Flags.Flag_Alloca_Call then
+ Binary_File.Memory.Set_Symbol_Address
+ (Ortho_Code.X86.Emits.Chkstk_Symbol, Chkstk'Address);
+ end if;
+ end Link_Intrinsics;
+end Ortho_Code.X86.Abi;
diff --git a/src/ortho/mcode/ortho_code-x86-abi.ads b/src/ortho/mcode/ortho_code-x86-abi.ads
new file mode 100644
index 000000000..7b166dad8
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-abi.ads
@@ -0,0 +1,76 @@
+-- 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.Types; use Ortho_Code.Types;
+
+package Ortho_Code.X86.Abi is
+ type O_Abi_Subprg is private;
+
+ procedure Init;
+ procedure Finish;
+
+ Mode_Align : 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, -- 2 for SVR4-ABI and Darwin, 3 for Windows.
+ Mode_Blk | Mode_X1 | Mode_Nil | Mode_P64 => 0,
+ Mode_B2 => 0);
+
+ Mode_Ptr : constant Mode_Type := Mode_P32;
+
+ Flag_Type_Completer : constant Boolean := False;
+ Flag_Lower_Stmt : constant Boolean := True;
+
+ Flag_Sse2 : Boolean := False;
+
+ -- 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/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb
new file mode 100644
index 000000000..ad1ef559b
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-emits.adb
@@ -0,0 +1,2322 @@
+-- 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.X86.Flags;
+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;
+
+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
+ 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
+ P : O_Enode;
+ L, R : O_Enode;
+ S, C : O_Enode;
+ Off : Int32;
+ begin
+ Off := 0;
+ P := N;
+ if Sz /= Sz_32l then
+ raise Program_Error;
+ end if;
+ loop
+ L := Get_Expr_Left (P);
+ R := Get_Expr_Right (P);
+
+ -- Extract the const node.
+ if Get_Expr_Kind (R) = OE_Const then
+ S := L;
+ C := R;
+ elsif 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;
+ Off := Off + To_Int32 (Get_Expr_Low (C));
+
+ exit when Get_Expr_Kind (S) = OE_Addrg;
+ P := S;
+ if Get_Expr_Kind (P) /= OE_Add then
+ raise Program_Error;
+ end if;
+ end loop;
+ Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (S)),
+ Integer_32 (Off));
+ 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_Reg_Xmm (R : O_Reg) return Byte is
+ begin
+ return O_Reg'Pos (R) - O_Reg'Pos (R_Xmm0);
+ end To_Reg_Xmm;
+ pragma Inline (To_Reg_Xmm);
+
+ 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;
+ R : O_Reg;
+ 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);
+
+ R := Get_Expr_Reg (Stmt);
+ case R is
+ when R_St0 =>
+ 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;
+ when Regs_Xmm =>
+ Start_Insn;
+ case Sz is
+ when Fp_32 =>
+ Gen_B8 (16#F3#);
+ when Fp_64 =>
+ Gen_B8 (16#F2#);
+ end case;
+ Gen_B8 (16#0f#);
+ Gen_B8 (16#10#);
+ Gen_B8 (2#00_000_101# + To_Reg_Xmm (R) * 2#1_000#);
+ Gen_X86_32 (Sym, 0);
+ End_Insn;
+ when others =>
+ raise Program_Error;
+ end case;
+ 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_Setup_Frame (Stmt : O_Enode)
+ is
+ Val : constant Int32 := Get_Stack_Adjust (Stmt);
+ begin
+ if Val > 0 then
+ Start_Insn;
+ -- subl esp, val
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_101_100#);
+ Gen_B8 (Byte (Val));
+ End_Insn;
+ elsif 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_Setup_Frame;
+
+ procedure Emit_Call (Stmt : O_Enode)
+ is
+ use Ortho_Code.Decls;
+ Subprg : O_Dnode;
+ Sym : Symbol;
+ begin
+ Subprg := Get_Call_Subprg (Stmt);
+ Sym := Get_Decl_Symbol (Subprg);
+ Gen_Call (Sym);
+ 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, (stack_boundary - 1)
+ Start_Insn;
+ Gen_B8 (2#1000_0011#);
+ Gen_B8 (2#11_000_000# + To_Reg32 (Reg));
+ Gen_B8 (Byte (X86.Flags.Stack_Boundary - 1));
+ End_Insn;
+ -- and reg, ~(stack_boundary - 1)
+ Start_Insn;
+ Gen_B8 (2#1000_0001#);
+ Gen_B8 (2#11_100_000# + To_Reg32 (Reg));
+ Gen_Le32 (not (X86.Flags.Stack_Boundary - 1));
+ End_Insn;
+ if X86.Flags.Flag_Alloca_Call then
+ Gen_Call (Chkstk_Symbol);
+ else
+ -- subl esp, reg
+ Start_Insn;
+ Gen_B8 (2#0001_1011#);
+ Gen_B8 (2#11_100_000# + To_Reg32 (Reg));
+ End_Insn;
+ end if;
+ -- 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_Res : O_Reg;
+ begin
+ Op := Get_Expr_Operand (Stmt);
+ 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_Res : O_Reg;
+ begin
+ Op := Get_Expr_Operand (Stmt);
+ 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;
+ begin
+ Op := Get_Expr_Operand (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
+ begin
+ 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_Stack_Adjust =>
+ Emit_Setup_Frame (Stmt);
+ 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 Ortho_Code.Flags;
+ use Ortho_Code.X86.Insns;
+ Sym : Symbol;
+ Subprg_Decl : O_Dnode;
+ Is_Global : Boolean;
+ Frame_Size : Unsigned_32;
+ Saved_Regs_Size : Unsigned_32;
+ begin
+ -- Switch to .text section and align the function (to avoid the nested
+ -- function trick and for performance).
+ Set_Current_Section (Sect_Text);
+ Gen_Pow_Align (2);
+
+ 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;
+
+ Saved_Regs_Size := Boolean'Pos(Reg_Used (R_Di)) * 4
+ + Boolean'Pos(Reg_Used (R_Si)) * 4
+ + Boolean'Pos(Reg_Used (R_Bx)) * 4;
+
+ -- Compute frame size.
+ -- 8 bytes are used by return address and saved frame pointer.
+ Frame_Size := Unsigned_32 (Subprg.Stack_Max) + 8 + Saved_Regs_Size;
+ -- Align.
+ Frame_Size := (Frame_Size + X86.Flags.Stack_Boundary - 1)
+ and not (X86.Flags.Stack_Boundary - 1);
+ -- The 8 bytes are already allocated.
+ Frame_Size := Frame_Size - 8 - Saved_Regs_Size;
+
+ -- 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 Frame_Size /= 0 then
+ if not X86.Flags.Flag_Alloca_Call
+ or else Frame_Size <= 4096
+ then
+ Start_Insn;
+ if Frame_Size < 128 then
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_101_100#);
+ Gen_B8 (Byte (Frame_Size));
+ else
+ Gen_B8 (2#100000_01#);
+ Gen_B8 (2#11_101_100#);
+ Gen_Le32 (Frame_Size);
+ end if;
+ End_Insn;
+ else
+ -- mov stack_size,%eax
+ Start_Insn;
+ Gen_B8 (2#1011_1_000#);
+ Gen_Le32 (Frame_Size);
+ End_Insn;
+ Gen_Call (Chkstk_Symbol);
+ end if;
+ 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 Ortho_Code.Decls;
+ use Ortho_Code.Types;
+ use Ortho_Code.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
+ | OC_Alignof
+ | OC_Union =>
+ 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;
+
+ if X86.Flags.Flag_Alloca_Call then
+ Chkstk_Symbol := Create_Symbol (Get_Identifier ("___chkstk"));
+ 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/src/ortho/mcode/ortho_code-x86-emits.ads b/src/ortho/mcode/ortho_code-x86-emits.ads
new file mode 100644
index 000000000..9ddb43ee5
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-emits.ads
@@ -0,0 +1,36 @@
+-- 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;
+ Chkstk_Symbol : Symbol;
+end Ortho_Code.X86.Emits;
+
diff --git a/src/ortho/mcode/ortho_code-x86-flags_linux.ads b/src/ortho/mcode/ortho_code-x86-flags_linux.ads
new file mode 100644
index 000000000..30bc7f7b3
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-flags_linux.ads
@@ -0,0 +1,31 @@
+-- X86 ABI flags.
+-- 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.X86.Flags_Linux is
+ -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc
+ -- modifies ESP directly.
+ Flag_Alloca_Call : constant Boolean := False;
+
+ -- Prefered stack alignment.
+ -- Must be a power of 2.
+ Stack_Boundary : constant Unsigned_32 := 2 ** 3;
+
+ -- Alignment for double (64 bit float).
+ Mode_F64_Align : constant Natural := 2;
+end Ortho_Code.X86.Flags_Linux;
diff --git a/src/ortho/mcode/ortho_code-x86-flags_macosx.ads b/src/ortho/mcode/ortho_code-x86-flags_macosx.ads
new file mode 100644
index 000000000..a33085294
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-flags_macosx.ads
@@ -0,0 +1,31 @@
+-- X86 ABI flags.
+-- 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.X86.Flags_Macosx is
+ -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc
+ -- modifies ESP directly.
+ Flag_Alloca_Call : constant Boolean := False;
+
+ -- Prefered stack alignment.
+ -- Must be a power of 2.
+ Stack_Boundary : constant Unsigned_32 := 2 ** 4;
+
+ -- Alignment for double (64 bit float).
+ Mode_F64_Align : constant Natural := 2;
+end Ortho_Code.X86.Flags_Macosx;
diff --git a/src/ortho/mcode/ortho_code-x86-flags_windows.ads b/src/ortho/mcode/ortho_code-x86-flags_windows.ads
new file mode 100644
index 000000000..3296aaf2c
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-flags_windows.ads
@@ -0,0 +1,31 @@
+-- X86 ABI flags.
+-- 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.X86.Flags_Windows is
+ -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc
+ -- modifies ESP directly.
+ Flag_Alloca_Call : constant Boolean := True;
+
+ -- Prefered stack alignment.
+ -- Must be a power of 2.
+ Stack_Boundary : constant Unsigned_32 := 2 ** 3;
+
+ -- Alignment for double (64 bit float).
+ Mode_F64_Align : constant Natural := 3;
+end Ortho_Code.X86.Flags_Windows;
diff --git a/src/ortho/mcode/ortho_code-x86-insns.adb b/src/ortho/mcode/ortho_code-x86-insns.adb
new file mode 100644
index 000000000..c218a9ae0
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-insns.adb
@@ -0,0 +1,2068 @@
+-- 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 Interfaces;
+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;
+with Ortho_Code.X86.Flags;
+
+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 =>
+ if Abi.Flag_Sse2 then
+ return R_Any_Xmm;
+ else
+ return R_St0;
+ end if;
+ 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;
+
+ -- Count how many bytes have been pushed on the stack, during a call. This
+ -- is used to correctly align the stack for nested calls.
+ Push_Offset : Uns32 := 0;
+
+ -- STMT is an OE_END statement.
+ -- Swap Stack_Offset with Max_Stack of STMT.
+ procedure Swap_Stack_Offset (Blk : O_Dnode)
+ is
+ 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
+ | OD_Subprg_Ext =>
+ 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;
+
+ -- Get the register in which a result of MODE is returned.
+ 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 =>
+ if Abi.Flag_Sse2 and True then
+ -- Note: this shouldn't be enabled as the svr4 ABI specifies
+ -- ST0.
+ return R_Xmm0;
+ else
+ return R_St0;
+ end if;
+ 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 : constant 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;
+
+ type Reg_Xmm_Info_Array is array (Regs_Xmm) of Reg_Info_Type;
+ Info_Regs_Xmm : Reg_Xmm_Info_Array := (others => Init_Reg_Info);
+
+ function Reg_Used (Reg : Regs_R32) return Boolean is
+ begin
+ return Regs (Reg).Used;
+ end Reg_Used;
+
+ procedure Dump_Reg32_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_Reg32_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_Reg32_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;
+
+ pragma Unreferenced (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);
+
+ -- Free_XX
+ -- Mark a register as unused.
+ 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 Free_Xmm (Reg : O_Reg) is
+ begin
+ if Info_Regs_Xmm (Reg).Num = O_Free then
+ raise Program_Error;
+ end if;
+ Info_Regs_Xmm (Reg).Num := O_Free;
+ end Free_Xmm;
+
+ -- Allocate a stack slot for spilling.
+ 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;
+
+ -- Insert a spill statement after ORIG: will save register(s) allocated by
+ -- ORIG.
+ -- Return the register(s) spilt (There might be several registers if
+ -- ORIG uses a R64 register).
+ function Insert_Spill (Orig : O_Enode) return O_Reg
+ is
+ N : O_Enode;
+ Mode : Mode_Type;
+ Reg_Orig : O_Reg;
+ begin
+ -- 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);
+ return Reg_Orig;
+ end Insert_Spill;
+
+ procedure Spill_R32 (Reg : Regs_R32)
+ is
+ Reg_Orig : O_Reg;
+ begin
+ if Regs (Reg).Num = O_Free then
+ -- This register was not allocated.
+ raise Program_Error;
+ end if;
+
+ Reg_Orig := Insert_Spill (Regs (Reg).Stmt);
+
+ -- 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;
+
+ procedure Spill_Xmm (Reg : Regs_Xmm)
+ is
+ Reg_Orig : O_Reg;
+ begin
+ if Info_Regs_Xmm (Reg).Num = O_Free then
+ -- This register was not allocated.
+ raise Program_Error;
+ end if;
+
+ Reg_Orig := Insert_Spill (Info_Regs_Xmm (Reg).Stmt);
+
+ -- Free the register.
+ if Reg_Orig /= Reg then
+ raise Program_Error;
+ end if;
+ Free_Xmm (Reg);
+ end Spill_Xmm;
+
+ procedure Alloc_Xmm (Reg : Regs_Xmm; Stmt : O_Enode; Num : O_Inum) is
+ begin
+ if Info_Regs_Xmm (Reg).Num /= O_Free then
+ Spill_Xmm (Reg);
+ end if;
+ Info_Regs_Xmm (Reg) := (Num => Num, Stmt => Stmt, Used => True);
+ end Alloc_Xmm;
+
+ procedure Clobber_Xmm (Reg : Regs_Xmm) is
+ begin
+ if Info_Regs_Xmm (Reg).Num /= O_Free then
+ Spill_Xmm (Reg);
+ end if;
+ end Clobber_Xmm;
+ pragma Unreferenced (Clobber_Xmm);
+
+ 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 Regs_Xmm =>
+ Alloc_Xmm (Reg, Stmt, Num);
+ 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 R_Any_Xmm =>
+ Best_Num := O_Inum'Last;
+ Best_Reg := R_None;
+ for I in Regs_X86_Xmm loop
+ if Info_Regs_Xmm (I).Num = O_Free then
+ Alloc_Xmm (I, Stmt, Num);
+ return I;
+ elsif Info_Regs_Xmm (I).Num <= Best_Num then
+ Best_Reg := I;
+ Best_Num := Info_Regs_Xmm (I).Num;
+ end if;
+ end loop;
+ Alloc_Xmm (Best_Reg, Stmt, Num);
+ return Best_Reg;
+ 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);
+ Spill := Insert_Move (Expr, Dest);
+ Alloc_R32 (Dest, Spill, Num);
+ return Spill;
+ when others =>
+ Error_Reg ("reload: unhandled dest in R32", Expr, Dest);
+ end case;
+ when Regs_R64 =>
+ return Expr;
+ when R_St0 =>
+ return Expr;
+ when Regs_Xmm =>
+ 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_Xmm =>
+ Free_Xmm (R);
+ 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;
+
+ -- REG is mandatory: the result of STMT must satisfy the REG constraint.
+ 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_Call (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum)
+ return O_Enode
+ is
+ use Interfaces;
+ Left : O_Enode;
+ Reg_Res : O_Reg;
+ Subprg : O_Dnode;
+ Push_Size : Uns32;
+ Pad : Uns32;
+ Res_Stmt : O_Enode;
+ begin
+ -- Emit Setup_Frame (to align stack).
+ Subprg := Get_Call_Subprg (Stmt);
+ Push_Size := Uns32 (Get_Subprg_Stack (Subprg));
+ -- Pad the stack if necessary.
+ Pad := (Push_Size + Push_Offset) and Uns32 (Flags.Stack_Boundary - 1);
+ if Pad /= 0 then
+ Pad := Uns32 (Flags.Stack_Boundary) - Pad;
+ Link_Stmt (New_Enode (OE_Stack_Adjust, Mode_Nil, O_Tnode_Null,
+ O_Enode (Pad), O_Enode_Null));
+ end if;
+ -- The stack has been adjusted by Pad bytes.
+ Push_Offset := Push_Offset + Pad;
+
+ -- Generate code for arguments (if any).
+ Left := Get_Arg_Link (Stmt);
+ if Left /= O_Enode_Null then
+ 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.
+
+ -- Add the call.
+ Reg_Res := Get_Call_Register (Get_Expr_Mode (Stmt));
+ Set_Expr_Reg (Stmt, Reg_Res);
+ Link_Stmt (Stmt);
+ Res_Stmt := Stmt;
+
+ if Push_Size + Pad /= 0 then
+ Res_Stmt :=
+ New_Enode (OE_Stack_Adjust, Get_Expr_Mode (Stmt), O_Tnode_Null,
+ O_Enode (-Int32 (Push_Size + Pad)), O_Enode_Null);
+ Set_Expr_Reg (Res_Stmt, Reg_Res);
+ Link_Stmt (Res_Stmt);
+ end if;
+
+ -- The stack has been restored (just after the call).
+ Push_Offset := Push_Offset - (Push_Size + Pad);
+
+ 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, Res_Stmt, Pnum);
+ return Res_Stmt;
+ when R_Any_Cc =>
+ -- Move to register.
+ -- (use the 'test' instruction).
+ Alloc_Cc (Res_Stmt, Pnum);
+ return Insert_Move (Res_Stmt, R_Ne);
+ when R_None =>
+ if Reg_Res /= R_None then
+ raise Program_Error;
+ end if;
+ return Res_Stmt;
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ end Gen_Call;
+
+ 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;
+ if Reg = R_St0 or not Abi.Flag_Sse2 then
+ Reg1 := R_St0;
+ else
+ Reg1 := R_Any_Xmm;
+ end if;
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, 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;
+ if X86.Flags.Flag_Alloca_Call then
+ Reg_L := R_Ax;
+ else
+ Reg_L := R_Any32;
+ end if;
+ Left := Gen_Insn (Left, Reg_L, Num);
+ Set_Expr_Operand (Stmt, Left);
+ Link_Stmt (Left);
+ Free_Insn_Regs (Left);
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg_L, 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;
+ Clobber_R32 (R_Dx);
+ else
+ Reg_Res := R_Dx;
+ Clobber_R32 (R_Ax);
+ end if;
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg_Res, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ return Reload (Stmt, Reg, Pnum);
+ when Mode_U64
+ | Mode_I64 =>
+ -- FIXME: align stack
+ 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);
+ Reg_Res := Inverse_Cc (Get_Expr_Reg (Left));
+ Free_Cc;
+ Set_Expr_Reg (Stmt, Reg_Res);
+ Alloc_Cc (Stmt, Pnum);
+ 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);
+ Reg_Res := Get_Expr_Reg (Left);
+ Free_Insn_Regs (Left);
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg_Res, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ return Stmt;
+ when OE_Conv =>
+ declare
+ O_Mode : Mode_Type; -- Operand mode
+ R_Mode : Mode_Type; -- Result mode
+ 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_Sib
+ | 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
+ -- Recurse on next argument, so the first argument is pushed
+ -- the last one.
+ 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);
+ Push_Offset := Push_Offset +
+ Do_Align (Get_Mode_Size (Get_Expr_Mode (Left)), Mode_U32);
+ Link_Stmt (Stmt);
+ Free_Insn_Regs (Left);
+ return Stmt;
+ when OE_Call =>
+ return Gen_Call (Stmt, Reg, Pnum);
+ 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 =>
+ Link_Stmt (Gen_Call (Stmt, R_None, Num));
+ 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;
+ 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);
+ 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;
+
+ -- Keep stack depth for this subprogram.
+ Subprg.Stack_Max := Stack_Max;
+
+ -- Sanity check: there must be no remaining pushed bytes.
+ if Push_Offset /= 0 then
+ raise Program_Error with "gen_subprg_insn: push_offset not 0";
+ end if;
+ end Gen_Subprg_Insns;
+
+end Ortho_Code.X86.Insns;
diff --git a/src/ortho/mcode/ortho_code-x86-insns.ads b/src/ortho/mcode/ortho_code-x86-insns.ads
new file mode 100644
index 000000000..9411737a0
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-x86.adb b/src/ortho/mcode/ortho_code-x86.adb
new file mode 100644
index 000000000..175dd7e99
--- /dev/null
+++ b/src/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/src/ortho/mcode/ortho_code-x86.ads b/src/ortho/mcode/ortho_code-x86.ads
new file mode 100644
index 000000000..24be1eb6c
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86.ads
@@ -0,0 +1,160 @@
+-- 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;
+
+ R_Any_Xmm : constant O_Reg := 79;
+
+ R_Xmm0 : constant O_Reg := 80;
+ R_Xmm1 : constant O_Reg := R_Xmm0 + 1;
+ R_Xmm2 : constant O_Reg := R_Xmm0 + 2;
+ R_Xmm3 : constant O_Reg := R_Xmm0 + 3;
+ R_Xmm4 : constant O_Reg := R_Xmm0 + 4;
+ R_Xmm5 : constant O_Reg := R_Xmm0 + 5;
+ R_Xmm6 : constant O_Reg := R_Xmm0 + 6;
+ R_Xmm7 : constant O_Reg := R_Xmm0 + 7;
+ R_Xmm8 : constant O_Reg := R_Xmm0 + 8;
+ R_Xmm9 : constant O_Reg := R_Xmm0 + 9;
+ R_Xmm10 : constant O_Reg := R_Xmm0 + 10;
+ R_Xmm11 : constant O_Reg := R_Xmm0 + 11;
+ R_Xmm12 : constant O_Reg := R_Xmm0 + 12;
+ R_Xmm13 : constant O_Reg := R_Xmm0 + 13;
+ R_Xmm14 : constant O_Reg := R_Xmm0 + 14;
+ R_Xmm15 : constant O_Reg := R_Xmm0 + 15;
+
+ subtype Regs_X86_64_Xmm is O_Reg range R_Xmm0 .. R_Xmm15;
+ subtype Regs_X86_Xmm is O_Reg range R_Xmm0 .. R_Xmm7;
+ subtype Regs_Xmm is O_Reg range R_Xmm0 .. R_Xmm15;
+
+ 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/src/ortho/mcode/ortho_code.ads b/src/ortho/mcode/ortho_code.ads
new file mode 100644
index 000000000..0657b07e6
--- /dev/null
+++ b/src/ortho/mcode/ortho_code.ads
@@ -0,0 +1,150 @@
+-- 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_Right_Arithmetic (L : Uns32; R : Natural) return Uns32;
+ pragma Import (Intrinsic, Shift_Right_Arithmetic);
+
+ 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/src/ortho/mcode/ortho_code_main.adb b/src/ortho/mcode/ortho_code_main.adb
new file mode 100644
index 000000000..a0e6dc6c6
--- /dev/null
+++ b/src/ortho/mcode/ortho_code_main.adb
@@ -0,0 +1,198 @@
+-- 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.Elf;
+with Binary_File.Coff;
+with Binary_File.Memory;
+
+procedure Ortho_Code_Main
+is
+ Output : String_Acc := null;
+ type Format_Type is (Format_Coff, Format_Elf);
+ Format : constant 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 : constant 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
+ Sym : Symbol;
+
+ type Func_Acc is access function return Integer;
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Pc_Type, 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/src/ortho/mcode/ortho_ident.adb b/src/ortho/mcode/ortho_ident.adb
new file mode 100644
index 000000000..0893b75dd
--- /dev/null
+++ b/src/ortho/mcode/ortho_ident.adb
@@ -0,0 +1,117 @@
+-- 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 + 1);
+ for I in Str'Range loop
+ Strs.Table (Start + I - Str'First) := Str (I);
+ end loop;
+ Strs.Table (Start + Str'Length) := ASCII.Nul;
+ 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 - 1;
+ else
+ return Ids.Table (Id + 1) - 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 : constant Natural := Ids.Table (Id);
+ begin
+ for I in Res'Range loop
+ Res (I) := Strs.Table (Start + I - Res'First);
+ end loop;
+ return Res;
+ end Get_String;
+
+ function Get_Cstring (Id : O_Ident) return System.Address is
+ begin
+ return Strs.Table (Ids.Table (Id))'Address;
+ end Get_Cstring;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean
+ is
+ Start : constant Natural := Ids.Table (Id);
+ Len : constant 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/src/ortho/mcode/ortho_ident.ads b/src/ortho/mcode/ortho_ident.ads
new file mode 100644
index 000000000..cdc42fcad
--- /dev/null
+++ b/src/ortho/mcode/ortho_ident.ads
@@ -0,0 +1,38 @@
+-- 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 System;
+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;
+
+ -- Note: the address is valid until the next call to get_identifier.
+ function Get_Cstring (Id : O_Ident) return System.Address;
+
+ O_Ident_Nul : constant O_Ident := Ortho_Code.O_Ident_Nul;
+
+ procedure Disp_Stats;
+ procedure Finish;
+end Ortho_Ident;
diff --git a/src/ortho/mcode/ortho_jit.adb b/src/ortho/mcode/ortho_jit.adb
new file mode 100644
index 000000000..7aa9724f2
--- /dev/null
+++ b/src/ortho/mcode/ortho_jit.adb
@@ -0,0 +1,125 @@
+-- Ortho JIT implementation for mcode.
+-- Copyright (C) 2009 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; use GNAT.OS_Lib;
+with Ada.Text_IO;
+
+with Binary_File; use Binary_File;
+with Binary_File.Memory;
+with Ortho_Mcode; use Ortho_Mcode;
+with Ortho_Mcode.Jit;
+with Ortho_Code.Flags; use Ortho_Code.Flags;
+with Ortho_Code.Debug;
+with Ortho_Code.Abi;
+with Binary_File.Elf;
+
+package body Ortho_Jit is
+ Snap_Filename : GNAT.OS_Lib.String_Access := null;
+
+ -- Initialize the whole engine.
+ procedure Init is
+ begin
+ Ortho_Mcode.Init;
+ Binary_File.Memory.Write_Memory_Init;
+ end Init;
+
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address)
+ renames Ortho_Mcode.Jit.Set_Address;
+
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address
+ renames Ortho_Mcode.Jit.Get_Address;
+
+ -- Do link.
+ procedure Link (Status : out Boolean) is
+ begin
+ if Ortho_Code.Debug.Flag_Debug_Hli then
+ -- Can't generate code in HLI.
+ Status := True;
+ return;
+ end if;
+
+ Ortho_Mcode.Finish;
+
+ Ortho_Code.Abi.Link_Intrinsics;
+
+ Binary_File.Memory.Write_Memory_Relocate (Status);
+ if Status then
+ return;
+ end if;
+
+ if Snap_Filename /= null then
+ declare
+ use Ada.Text_IO;
+ Fd : File_Descriptor;
+ begin
+ Fd := Create_File (Snap_Filename.all, Binary);
+ if Fd = Invalid_FD then
+ Put_Line (Standard_Error,
+ "can't open '" & Snap_Filename.all & "'");
+ Status := False;
+ return;
+ else
+ Binary_File.Elf.Write_Elf (Fd);
+ Close (Fd);
+ end if;
+ end;
+ end if;
+ end Link;
+
+ procedure Finish is
+ begin
+ -- Free all the memory.
+ Ortho_Mcode.Free_All;
+
+ Binary_File.Finish;
+ end Finish;
+
+ function Decode_Option (Option : String) return Boolean
+ is
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ if Opt = "-g" then
+ Flag_Debug := Debug_Dwarf;
+ return True;
+ elsif Opt'Length > 5 and then Opt (1 .. 5) = "--be-" then
+ Ortho_Code.Debug.Set_Be_Flag (Opt);
+ return True;
+ elsif Opt'Length > 7 and then Opt (1 .. 7) = "--snap=" then
+ Snap_Filename := new String'(Opt (8 .. Opt'Last));
+ return True;
+ else
+ return False;
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Help is
+ use Ada.Text_IO;
+ begin
+ Put_Line (" -g Generate debugging informations");
+ Put_Line (" --debug-be=X Set X internal debugging flags");
+ Put_Line (" --snap=FILE Write memory snapshot to FILE");
+ end Disp_Help;
+
+ function Get_Jit_Name return String is
+ begin
+ return "mcode";
+ end Get_Jit_Name;
+
+end Ortho_Jit;
diff --git a/src/ortho/mcode/ortho_mcode-jit.adb b/src/ortho/mcode/ortho_mcode-jit.adb
new file mode 100644
index 000000000..7e845cc6e
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode-jit.adb
@@ -0,0 +1,28 @@
+with Ada.Unchecked_Conversion;
+
+with Ortho_Code.Binary;
+with Binary_File; use Binary_File;
+with Binary_File.Memory;
+
+package body Ortho_Mcode.Jit is
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address)
+ is
+ use Ortho_Code.Binary;
+ begin
+ Binary_File.Memory.Set_Symbol_Address
+ (Get_Decl_Symbol (Ortho_Code.O_Dnode (Decl)), Addr);
+ end Set_Address;
+
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address
+ is
+ use Ortho_Code.Binary;
+
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Pc_Type, Target => Address);
+ begin
+ return Conv (Get_Symbol_Vaddr
+ (Get_Decl_Symbol (Ortho_Code.O_Dnode (Decl))));
+ end Get_Address;
+end Ortho_Mcode.Jit;
diff --git a/src/ortho/mcode/ortho_mcode-jit.ads b/src/ortho/mcode/ortho_mcode-jit.ads
new file mode 100644
index 000000000..c689a1e12
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode-jit.ads
@@ -0,0 +1,9 @@
+with System; use System;
+
+package Ortho_Mcode.Jit is
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address);
+
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address;
+end Ortho_Mcode.Jit;
diff --git a/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb
new file mode 100644
index 000000000..55e890bf3
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode.adb
@@ -0,0 +1,738 @@
+-- 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 Ortho_Code.Debug;
+with Ortho_Ident;
+with Ortho_Code.Abi;
+-- with Binary_File;
+
+package body Ortho_Mcode is
+ procedure New_Debug_Comment_Stmt (Comment : String)
+ is
+ pragma Unreferenced (Comment);
+ begin
+ null;
+ end New_Debug_Comment_Stmt;
+
+ procedure Start_Const_Value (Const : in out O_Dnode)
+ is
+ pragma Unreferenced (Const);
+ begin
+ null;
+ end Start_Const_Value;
+
+ procedure Start_Record_Type (Elements : out O_Element_List) is
+ begin
+ Ortho_Code.Types.Start_Record_Type
+ (Ortho_Code.Types.O_Element_List (Elements));
+ end Start_Record_Type;
+
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode) is
+ begin
+ Ortho_Code.Types.New_Record_Field
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Fnode (El), Ident, Ortho_Code.O_Tnode (Etype));
+ end New_Record_Field;
+
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Record_Type
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Tnode (Res));
+ end Finish_Record_Type;
+
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.New_Uncomplete_Record_Type (Ortho_Code.O_Tnode (Res));
+ end New_Uncomplete_Record_Type;
+
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List) is
+ begin
+ Ortho_Code.Types.Start_Uncomplete_Record_Type
+ (Ortho_Code.O_Tnode (Res),
+ Ortho_Code.Types.O_Element_List (Elements));
+ end Start_Uncomplete_Record_Type;
+
+ procedure Start_Union_Type (Elements : out O_Element_List) is
+ begin
+ Ortho_Code.Types.Start_Union_Type
+ (Ortho_Code.Types.O_Element_List (Elements));
+ 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
+ begin
+ Ortho_Code.Types.New_Union_Field
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Fnode (El),
+ Ident,
+ Ortho_Code.O_Tnode (Etype));
+ end New_Union_Field;
+
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Union_Type
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Tnode (Res));
+ end Finish_Union_Type;
+
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode is
+ begin
+ return O_Tnode
+ (Ortho_Code.Types.New_Access_Type (Ortho_Code.O_Tnode (Dtype)));
+ end New_Access_Type;
+
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Access_Type (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Tnode (Dtype));
+ end Finish_Access_Type;
+
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode)
+ is
+ pragma Warnings (Off, Const);
+ begin
+ New_Const_Value (Ortho_Code.O_Dnode (Const), Ortho_Code.O_Cnode (Val));
+ end Finish_Const_Value;
+
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode is
+ begin
+ return O_Tnode
+ (Ortho_Code.Types.New_Array_Type (Ortho_Code.O_Tnode (El_Type),
+ Ortho_Code.O_Tnode (Index_Type)));
+ end New_Array_Type;
+
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode
+ is
+ Len : constant Ortho_Code.O_Cnode := Ortho_Code.O_Cnode (Length);
+ L_Type : Ortho_Code.O_Tnode;
+ begin
+ L_Type := Get_Const_Type (Len);
+ if Get_Type_Kind (L_Type) /= OT_Unsigned then
+ raise Syntax_Error;
+ end if;
+ return O_Tnode (New_Constrained_Array_Type
+ (Ortho_Code.O_Tnode (Atype), Get_Const_U32 (Len)));
+ end New_Constrained_Array_Type;
+
+ function New_Unsigned_Type (Size : Natural) return O_Tnode is
+ begin
+ return O_Tnode (Ortho_Code.Types.New_Unsigned_Type (Size));
+ end New_Unsigned_Type;
+
+ function New_Signed_Type (Size : Natural) return O_Tnode is
+ begin
+ return O_Tnode (Ortho_Code.Types.New_Signed_Type (Size));
+ end New_Signed_Type;
+
+ function New_Float_Type return O_Tnode is
+ begin
+ return O_Tnode (Ortho_Code.Types.New_Float_Type);
+ end New_Float_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) is
+ begin
+ Ortho_Code.Types.New_Boolean_Type (Ortho_Code.O_Tnode (Res),
+ False_Id,
+ Ortho_Code.O_Cnode (False_E),
+ True_Id,
+ Ortho_Code.O_Cnode (True_E));
+ end New_Boolean_Type;
+
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) is
+ begin
+ Ortho_Code.Types.Start_Enum_Type (Ortho_Code.Types.O_Enum_List (List),
+ Size);
+ end Start_Enum_Type;
+
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode) is
+ begin
+ Ortho_Code.Types.New_Enum_Literal (Ortho_Code.Types.O_Enum_List (List),
+ Ident, Ortho_Code.O_Cnode (Res));
+ end New_Enum_Literal;
+
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Enum_Type (Ortho_Code.Types.O_Enum_List (List),
+ Ortho_Code.O_Tnode (Res));
+ end Finish_Enum_Type;
+
+ -------------------
+ -- Expressions --
+ -------------------
+
+ To_Op : constant array (ON_Op_Kind) of Ortho_Code.ON_Op_Kind :=
+ (
+ ON_Nil => ON_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov => ON_Add_Ov,
+ ON_Sub_Ov => ON_Sub_Ov,
+ ON_Mul_Ov => ON_Mul_Ov,
+ ON_Div_Ov => ON_Div_Ov,
+ ON_Rem_Ov => ON_Rem_Ov,
+ ON_Mod_Ov => ON_Mod_Ov,
+
+ -- Binary operations.
+ ON_And => ON_And,
+ ON_Or => ON_Or,
+ ON_Xor => ON_Xor,
+
+ -- Monadic operations.
+ ON_Not => ON_Not,
+ ON_Neg_Ov => ON_Neg_Ov,
+ ON_Abs_Ov => ON_Abs_Ov,
+
+ -- Comparaisons
+ ON_Eq => ON_Eq,
+ ON_Neq => ON_Neq,
+ ON_Le => ON_Le,
+ ON_Lt => ON_Lt,
+ ON_Ge => ON_Ge,
+ ON_Gt => ON_Gt
+ );
+
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Signed_Literal (Ortho_Code.O_Tnode (Ltype),
+ Value));
+ end New_Signed_Literal;
+
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Unsigned_Literal (Ortho_Code.O_Tnode (Ltype),
+ Value));
+ end New_Unsigned_Literal;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Float_Literal (Ortho_Code.O_Tnode (Ltype),
+ Value));
+ end New_Float_Literal;
+
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Null_Access (Ortho_Code.O_Tnode (Ltype)));
+ end New_Null_Access;
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode) is
+ begin
+ Ortho_Code.Consts.Start_Record_Aggr
+ (Ortho_Code.Consts.O_Record_Aggr_List (List),
+ Ortho_Code.O_Tnode (Atype));
+ end Start_Record_Aggr;
+
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode) is
+ begin
+ Ortho_Code.Consts.New_Record_Aggr_El
+ (Ortho_Code.Consts.O_Record_Aggr_List (List),
+ Ortho_Code.O_Cnode (Value));
+ end New_Record_Aggr_El;
+
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode) is
+ begin
+ Ortho_Code.Consts.Finish_Record_Aggr
+ (Ortho_Code.Consts.O_Record_Aggr_List (List),
+ Ortho_Code.O_Cnode (Res));
+ end Finish_Record_Aggr;
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode)
+ is
+ begin
+ Ortho_Code.Consts.Start_Array_Aggr
+ (Ortho_Code.Consts.O_Array_Aggr_List (List),
+ Ortho_Code.O_Tnode (Atype));
+ end Start_Array_Aggr;
+
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode) is
+ begin
+ Ortho_Code.Consts.New_Array_Aggr_El
+ (Ortho_Code.Consts.O_Array_Aggr_List (List),
+ Ortho_Code.O_Cnode (Value));
+ end New_Array_Aggr_El;
+
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode) is
+ begin
+ Ortho_Code.Consts.Finish_Array_Aggr
+ (Ortho_Code.Consts.O_Array_Aggr_List (List),
+ Ortho_Code.O_Cnode (Res));
+ end Finish_Array_Aggr;
+
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Union_Aggr (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Fnode (Field),
+ Ortho_Code.O_Cnode (Value)));
+ end New_Union_Aggr;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Sizeof (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Sizeof;
+
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Alignof (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Alignof;
+
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Offsetof (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Fnode (Field),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Offsetof;
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Subprogram_Address
+ (Ortho_Code.O_Dnode (Subprg), Ortho_Code.O_Tnode (Atype)));
+ end New_Subprogram_Address;
+
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Global_Address
+ (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype)));
+ end New_Global_Address;
+
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Global_Unchecked_Address
+ (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype)));
+ end New_Global_Unchecked_Address;
+
+ function New_Lit (Lit : O_Cnode) return O_Enode is
+ begin
+ return O_Enode (Ortho_Code.Exprs.New_Lit (Ortho_Code.O_Cnode (Lit)));
+ end New_Lit;
+
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Dyadic_Op (To_Op (Kind),
+ Ortho_Code.O_Enode (Left),
+ Ortho_Code.O_Enode (Right)));
+ end New_Dyadic_Op;
+
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Monadic_Op (To_Op (Kind),
+ Ortho_Code.O_Enode (Operand)));
+ end New_Monadic_Op;
+
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Compare_Op (To_Op (Kind),
+ Ortho_Code.O_Enode (Left),
+ Ortho_Code.O_Enode (Right),
+ Ortho_Code.O_Tnode (Ntype)));
+ end New_Compare_Op;
+
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode is
+ begin
+ return O_Lnode
+ (Ortho_Code.Exprs.New_Indexed_Element (Ortho_Code.O_Lnode (Arr),
+ Ortho_Code.O_Enode (Index)));
+ end New_Indexed_Element;
+
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode is
+ begin
+ return O_Lnode
+ (Ortho_Code.Exprs.New_Slice (Ortho_Code.O_Lnode (Arr),
+ Ortho_Code.O_Tnode (Res_Type),
+ Ortho_Code.O_Enode (Index)));
+ end New_Slice;
+
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode is
+ begin
+ return O_Lnode
+ (Ortho_Code.Exprs.New_Selected_Element (Ortho_Code.O_Lnode (Rec),
+ Ortho_Code.O_Fnode (El)));
+ end New_Selected_Element;
+
+ function New_Access_Element (Acc : O_Enode) return O_Lnode is
+ begin
+ return O_Lnode
+ (Ortho_Code.Exprs.New_Access_Element (Ortho_Code.O_Enode (Acc)));
+ end New_Access_Element;
+
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Convert_Ov (Ortho_Code.O_Enode (Val),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Convert_Ov;
+
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Address (Ortho_Code.O_Lnode (Lvalue),
+ Ortho_Code.O_Tnode (Atype)));
+ end New_Address;
+
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Unchecked_Address (Ortho_Code.O_Lnode (Lvalue),
+ Ortho_Code.O_Tnode (Atype)));
+ end New_Unchecked_Address;
+
+ function New_Value (Lvalue : O_Lnode) return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Value (Ortho_Code.O_Lnode (Lvalue)));
+ end New_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_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode is
+ begin
+ return O_Enode (Ortho_Code.Exprs.New_Alloca (Ortho_Code.O_Tnode (Rtype),
+ Ortho_Code.O_Enode (Size)));
+ end New_Alloca;
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ procedure New_Debug_Filename_Decl (Filename : String)
+ renames Ortho_Code.Abi.New_Debug_Filename_Decl;
+
+ procedure New_Debug_Line_Decl (Line : Natural)
+ is
+ pragma Unreferenced (Line);
+ begin
+ null;
+ end New_Debug_Line_Decl;
+
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is
+ begin
+ Ortho_Code.Decls.New_Type_Decl (Ident, Ortho_Code.O_Tnode (Atype));
+ end New_Type_Decl;
+
+ To_Storage : constant array (O_Storage) of Ortho_Code.O_Storage :=
+ (O_Storage_External => O_Storage_External,
+ O_Storage_Public => O_Storage_Public,
+ O_Storage_Private => O_Storage_Private,
+ O_Storage_Local => O_Storage_Local);
+
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode) is
+ begin
+ Ortho_Code.Decls.New_Const_Decl
+ (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage),
+ Ortho_Code.O_Tnode (Atype));
+ end New_Const_Decl;
+
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode) is
+ begin
+ Ortho_Code.Decls.New_Var_Decl
+ (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage),
+ Ortho_Code.O_Tnode (Atype));
+ end New_Var_Decl;
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode is
+ begin
+ return O_Lnode (Ortho_Code.Exprs.New_Obj (Ortho_Code.O_Dnode (Obj)));
+ end New_Obj;
+
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode) is
+ begin
+ Ortho_Code.Decls.Start_Function_Decl
+ (Ortho_Code.Decls.O_Inter_List (Interfaces),
+ Ident, To_Storage (Storage), Ortho_Code.O_Tnode (Rtype));
+ end Start_Function_Decl;
+
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage) is
+ begin
+ Ortho_Code.Decls.Start_Procedure_Decl
+ (Ortho_Code.Decls.O_Inter_List (Interfaces),
+ Ident, To_Storage (Storage));
+ 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
+ Ortho_Code.Decls.New_Interface_Decl
+ (Ortho_Code.Decls.O_Inter_List (Interfaces),
+ Ortho_Code.O_Dnode (Res),
+ Ident,
+ Ortho_Code.O_Tnode (Atype));
+ end New_Interface_Decl;
+
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode) is
+ begin
+ Ortho_Code.Decls.Finish_Subprogram_Decl
+ (Ortho_Code.Decls.O_Inter_List (Interfaces), Ortho_Code.O_Dnode (Res));
+ end Finish_Subprogram_Decl;
+
+ procedure Start_Subprogram_Body (Func : O_Dnode) is
+ begin
+ Ortho_Code.Exprs.Start_Subprogram_Body (Ortho_Code.O_Dnode (Func));
+ end Start_Subprogram_Body;
+
+ procedure Finish_Subprogram_Body
+ renames Ortho_Code.Exprs.Finish_Subprogram_Body;
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ procedure New_Debug_Line_Stmt (Line : Natural)
+ renames Ortho_Code.Exprs.New_Debug_Line_Stmt;
+
+ procedure New_Debug_Comment_Decl (Comment : String)
+ is
+ pragma Unreferenced (Comment);
+ begin
+ null;
+ end New_Debug_Comment_Decl;
+
+ procedure Start_Declare_Stmt renames
+ Ortho_Code.Exprs.Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt renames
+ Ortho_Code.Exprs.Finish_Declare_Stmt;
+
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) is
+ begin
+ Ortho_Code.Exprs.Start_Association
+ (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Dnode (Subprg));
+ end Start_Association;
+
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is
+ begin
+ Ortho_Code.Exprs.New_Association
+ (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Enode (Val));
+ end New_Association;
+
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode is
+ begin
+ return O_Enode (Ortho_Code.Exprs.New_Function_Call
+ (Ortho_Code.Exprs.O_Assoc_List (Assocs)));
+ end New_Function_Call;
+
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is
+ begin
+ Ortho_Code.Exprs.New_Procedure_Call
+ (Ortho_Code.Exprs.O_Assoc_List (Assocs));
+ end New_Procedure_Call;
+
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) is
+ begin
+ Ortho_Code.Exprs.New_Assign_Stmt (Ortho_Code.O_Lnode (Target),
+ Ortho_Code.O_Enode (Value));
+ end New_Assign_Stmt;
+
+ procedure New_Return_Stmt (Value : O_Enode) is
+ begin
+ Ortho_Code.Exprs.New_Return_Stmt (Ortho_Code.O_Enode (Value));
+ end New_Return_Stmt;
+
+ procedure New_Return_Stmt
+ renames Ortho_Code.Exprs.New_Return_Stmt;
+
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is
+ begin
+ Ortho_Code.Exprs.Start_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block),
+ Ortho_Code.O_Enode (Cond));
+ end Start_If_Stmt;
+
+ procedure New_Else_Stmt (Block : in out O_If_Block) is
+ begin
+ Ortho_Code.Exprs.New_Else_Stmt (Ortho_Code.Exprs.O_If_Block (Block));
+ end New_Else_Stmt;
+
+ procedure Finish_If_Stmt (Block : in out O_If_Block) is
+ begin
+ Ortho_Code.Exprs.Finish_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block));
+ end Finish_If_Stmt;
+
+ procedure Start_Loop_Stmt (Label : out O_Snode) is
+ begin
+ Ortho_Code.Exprs.Start_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label));
+ end Start_Loop_Stmt;
+
+ procedure Finish_Loop_Stmt (Label : in out O_Snode) is
+ begin
+ Ortho_Code.Exprs.Finish_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label));
+ end Finish_Loop_Stmt;
+
+ procedure New_Exit_Stmt (L : O_Snode) is
+ begin
+ Ortho_Code.Exprs.New_Exit_Stmt (Ortho_Code.Exprs.O_Snode (L));
+ end New_Exit_Stmt;
+
+ procedure New_Next_Stmt (L : O_Snode) is
+ begin
+ Ortho_Code.Exprs.New_Next_Stmt (Ortho_Code.Exprs.O_Snode (L));
+ end New_Next_Stmt;
+
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is
+ begin
+ Ortho_Code.Exprs.Start_Case_Stmt
+ (Ortho_Code.Exprs.O_Case_Block (Block), Ortho_Code.O_Enode (Value));
+ end Start_Case_Stmt;
+
+ procedure Start_Choice (Block : in out O_Case_Block) is
+ begin
+ Ortho_Code.Exprs.Start_Choice (Ortho_Code.Exprs.O_Case_Block (Block));
+ end Start_Choice;
+
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is
+ begin
+ Ortho_Code.Exprs.New_Expr_Choice (Ortho_Code.Exprs.O_Case_Block (Block),
+ Ortho_Code.O_Cnode (Expr));
+ end New_Expr_Choice;
+
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode) is
+ begin
+ Ortho_Code.Exprs.New_Range_Choice
+ (Ortho_Code.Exprs.O_Case_Block (Block),
+ Ortho_Code.O_Cnode (Low), Ortho_Code.O_Cnode (High));
+ end New_Range_Choice;
+
+ procedure New_Default_Choice (Block : in out O_Case_Block) is
+ begin
+ Ortho_Code.Exprs.New_Default_Choice
+ (Ortho_Code.Exprs.O_Case_Block (Block));
+ end New_Default_Choice;
+
+ procedure Finish_Choice (Block : in out O_Case_Block) is
+ begin
+ Ortho_Code.Exprs.Finish_Choice (Ortho_Code.Exprs.O_Case_Block (Block));
+ end Finish_Choice;
+
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block) is
+ begin
+ Ortho_Code.Exprs.Finish_Case_Stmt
+ (Ortho_Code.Exprs.O_Case_Block (Block));
+ end Finish_Case_Stmt;
+
+ procedure Init is
+ begin
+ -- Create an anonymous pointer type.
+ if New_Access_Type (O_Tnode_Null) /= O_Tnode (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/src/ortho/mcode/ortho_mcode.ads b/src/ortho/mcode/ortho_mcode.ads
new file mode 100644
index 000000000..45e803690
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode.ads
@@ -0,0 +1,583 @@
+-- DO NOT MODIFY - this file was generated from:
+-- ortho_nodes.common.ads and ortho_mcode.private.ads
+--
+-- 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;
+
+-- Interface to create nodes.
+package Ortho_Mcode is
+ -- Initialize nodes.
+ procedure Init;
+ procedure Finish;
+
+ procedure Free_All;
+
+-- Start of common part
+
+ type O_Enode is private;
+ type O_Cnode is private;
+ type O_Lnode is private;
+ type O_Tnode is private;
+ type O_Snode is private;
+ type O_Dnode is private;
+ type O_Fnode is private;
+
+ O_Cnode_Null : constant O_Cnode;
+ O_Dnode_Null : constant O_Dnode;
+ O_Enode_Null : constant O_Enode;
+ O_Fnode_Null : constant O_Fnode;
+ O_Lnode_Null : constant O_Lnode;
+ O_Snode_Null : constant O_Snode;
+ O_Tnode_Null : constant O_Tnode;
+
+ -- True if the code generated supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean;
+
+ ------------------------
+ -- Type definitions --
+ ------------------------
+
+ 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);
+
+ -- 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 : 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;
+ 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);
+
+ ----------------
+ -- Literals --
+ ----------------
+
+ -- 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;
+
+ -- 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.
+ type O_Record_Aggr_List is limited private;
+ type O_Array_Aggr_List is limited private;
+
+ 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 alignment in bytes for ATYPE. The result is a literal of
+ -- unsgined type RTYPE.
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the offset of FIELD in its record ATYPE. The result is a
+ -- literal of unsigned type or access type RTYPE.
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of a subprogram.
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- 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_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -------------------
+ -- Expressions --
+ -------------------
+
+ 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;
+
+ type O_Storage is (O_Storage_External,
+ O_Storage_Public,
+ O_Storage_Private,
+ O_Storage_Local);
+ -- 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_Error : exception;
+ Syntax_Error : exception;
+
+ -- Create a value from a literal.
+ function New_Lit (Lit : O_Cnode) return O_Enode;
+
+ -- 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;
+
+
+ type O_Inter_List is limited private;
+ type O_Assoc_List is limited private;
+ type O_If_Block is limited private;
+ type O_Case_Block is limited private;
+
+
+ -- 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 value of an Lvalue.
+ function New_Value (Lvalue : O_Lnode) return O_Enode;
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode;
+
+ -- Get an lvalue from a declaration.
+ function New_Obj (Obj : O_Dnode) return O_Lnode;
+
+ -- 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;
+
+ -- Declare a type.
+ -- This simply gives a name to a type.
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode);
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ -- Filename of the next declaration.
+ procedure New_Debug_Filename_Decl (Filename : String);
+
+ -- 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 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 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);
+
+ -- 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 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;
+
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ -- Add a line number as a statement.
+ procedure New_Debug_Line_Stmt (Line : Natural);
+
+ -- 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);
+ 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;
+
+ -- Build an IF statement.
+ procedure Start_If_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);
+
+ -- 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.
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode);
+ -- A choice branch is composed of expr, range or default choices.
+ -- A choice branch is enclosed between a Start_Choice and a Finish_Choice.
+ -- The statements are after the finish_choice.
+ 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);
+
+-- End of common part
+private
+ -- MCode supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean := True;
+
+ type O_Tnode is new Ortho_Code.O_Tnode;
+ type O_Cnode is new Ortho_Code.O_Cnode;
+ type O_Dnode is new Ortho_Code.O_Dnode;
+ type O_Enode is new Ortho_Code.O_Enode;
+ type O_Fnode is new Ortho_Code.O_Fnode;
+ type O_Lnode is new Ortho_Code.O_Lnode;
+ type O_Snode is new Ortho_Code.Exprs.O_Snode;
+
+ O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null);
+ O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null);
+ O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null);
+ O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null);
+ O_Fnode_Null : constant O_Fnode := O_Fnode (Ortho_Code.O_Fnode_Null);
+ O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null);
+ O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null);
+
+ type O_Element_List is new Ortho_Code.Types.O_Element_List;
+ type O_Enum_List is new Ortho_Code.Types.O_Enum_List;
+ type O_Inter_List is new Ortho_Code.Decls.O_Inter_List;
+ type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List;
+ type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List;
+ type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List;
+ type O_If_Block is new Ortho_Code.Exprs.O_If_Block;
+ type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block;
+
+ pragma Inline (New_Lit);
+ pragma Inline (New_Dyadic_Op);
+ pragma Inline (New_Monadic_Op);
+ pragma Inline (New_Compare_Op);
+ pragma Inline (New_Signed_Literal);
+ pragma Inline (New_Unsigned_Literal);
+ pragma Inline (New_Float_Literal);
+ pragma Inline (New_Null_Access);
+
+ pragma Inline (Start_Record_Aggr);
+ pragma Inline (New_Record_Aggr_El);
+ pragma Inline (Finish_Record_Aggr);
+
+ pragma Inline (Start_Array_Aggr);
+ pragma Inline (New_Array_Aggr_El);
+ pragma Inline (Finish_Array_Aggr);
+
+ pragma Inline (New_Union_Aggr);
+ pragma Inline (New_Sizeof);
+ pragma Inline (New_Alignof);
+ pragma Inline (New_Offsetof);
+
+ pragma Inline (New_Indexed_Element);
+ pragma Inline (New_Slice);
+ pragma Inline (New_Selected_Element);
+ pragma Inline (New_Access_Element);
+
+ pragma Inline (New_Convert_Ov);
+
+ pragma Inline (New_Address);
+ pragma Inline (New_Global_Address);
+ pragma Inline (New_Unchecked_Address);
+ pragma Inline (New_Global_Unchecked_Address);
+ pragma Inline (New_Subprogram_Address);
+
+ pragma Inline (New_Value);
+ pragma Inline (New_Obj_Value);
+
+ pragma Inline (New_Alloca);
+
+ pragma Inline (New_Debug_Filename_Decl);
+ pragma Inline (New_Debug_Line_Decl);
+ pragma Inline (New_Debug_Comment_Decl);
+
+ pragma Inline (New_Type_Decl);
+ pragma Inline (New_Const_Decl);
+
+ pragma Inline (Start_Const_Value);
+ pragma Inline (Finish_Const_Value);
+ pragma Inline (New_Var_Decl);
+
+ pragma Inline (New_Obj);
+ pragma Inline (Start_Function_Decl);
+ pragma Inline (Start_Procedure_Decl);
+ pragma Inline (New_Interface_Decl);
+ pragma Inline (Finish_Subprogram_Decl);
+ pragma Inline (Start_Subprogram_Body);
+ pragma Inline (Finish_Subprogram_Body);
+
+ pragma Inline (New_Debug_Line_Stmt);
+ pragma Inline (New_Debug_Comment_Stmt);
+
+ pragma Inline (Start_Declare_Stmt);
+ pragma Inline (Finish_Declare_Stmt);
+
+ -- Create a function call or a procedure call.
+ pragma Inline (Start_Association);
+ pragma Inline (New_Association);
+ pragma Inline (New_Function_Call);
+ pragma Inline (New_Procedure_Call);
+
+ pragma Inline (New_Assign_Stmt);
+ pragma Inline (New_Return_Stmt);
+ pragma Inline (Start_If_Stmt);
+ pragma Inline (New_Else_Stmt);
+ pragma Inline (Finish_If_Stmt);
+
+ pragma Inline (Start_Loop_Stmt);
+ pragma Inline (Finish_Loop_Stmt);
+ pragma Inline (New_Exit_Stmt);
+ pragma Inline (New_Next_Stmt);
+
+ pragma Inline (Start_Case_Stmt);
+ pragma Inline (Start_Choice);
+ pragma Inline (New_Expr_Choice);
+ pragma Inline (New_Range_Choice);
+ pragma Inline (New_Default_Choice);
+ pragma Inline (Finish_Choice);
+ pragma Inline (Finish_Case_Stmt);
+end Ortho_Mcode;
diff --git a/src/ortho/mcode/ortho_mcode.private.ads b/src/ortho/mcode/ortho_mcode.private.ads
new file mode 100644
index 000000000..1b414773f
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode.private.ads
@@ -0,0 +1,151 @@
+-- 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;
+
+-- Interface to create nodes.
+package Ortho_Mcode is
+ -- Initialize nodes.
+ procedure Init;
+ procedure Finish;
+
+ procedure Free_All;
+
+private
+ -- MCode supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean := True;
+
+ type O_Tnode is new Ortho_Code.O_Tnode;
+ type O_Cnode is new Ortho_Code.O_Cnode;
+ type O_Dnode is new Ortho_Code.O_Dnode;
+ type O_Enode is new Ortho_Code.O_Enode;
+ type O_Fnode is new Ortho_Code.O_Fnode;
+ type O_Lnode is new Ortho_Code.O_Lnode;
+ type O_Snode is new Ortho_Code.Exprs.O_Snode;
+
+ O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null);
+ O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null);
+ O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null);
+ O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null);
+ O_Fnode_Null : constant O_Fnode := O_Fnode (Ortho_Code.O_Fnode_Null);
+ O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null);
+ O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null);
+
+ type O_Element_List is new Ortho_Code.Types.O_Element_List;
+ type O_Enum_List is new Ortho_Code.Types.O_Enum_List;
+ type O_Inter_List is new Ortho_Code.Decls.O_Inter_List;
+ type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List;
+ type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List;
+ type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List;
+ type O_If_Block is new Ortho_Code.Exprs.O_If_Block;
+ type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block;
+
+ pragma Inline (New_Lit);
+ pragma Inline (New_Dyadic_Op);
+ pragma Inline (New_Monadic_Op);
+ pragma Inline (New_Compare_Op);
+ pragma Inline (New_Signed_Literal);
+ pragma Inline (New_Unsigned_Literal);
+ pragma Inline (New_Float_Literal);
+ pragma Inline (New_Null_Access);
+
+ pragma Inline (Start_Record_Aggr);
+ pragma Inline (New_Record_Aggr_El);
+ pragma Inline (Finish_Record_Aggr);
+
+ pragma Inline (Start_Array_Aggr);
+ pragma Inline (New_Array_Aggr_El);
+ pragma Inline (Finish_Array_Aggr);
+
+ pragma Inline (New_Union_Aggr);
+ pragma Inline (New_Sizeof);
+ pragma Inline (New_Alignof);
+ pragma Inline (New_Offsetof);
+
+ pragma Inline (New_Indexed_Element);
+ pragma Inline (New_Slice);
+ pragma Inline (New_Selected_Element);
+ pragma Inline (New_Access_Element);
+
+ pragma Inline (New_Convert_Ov);
+
+ pragma Inline (New_Address);
+ pragma Inline (New_Global_Address);
+ pragma Inline (New_Unchecked_Address);
+ pragma Inline (New_Global_Unchecked_Address);
+ pragma Inline (New_Subprogram_Address);
+
+ pragma Inline (New_Value);
+ pragma Inline (New_Obj_Value);
+
+ pragma Inline (New_Alloca);
+
+ pragma Inline (New_Debug_Filename_Decl);
+ pragma Inline (New_Debug_Line_Decl);
+ pragma Inline (New_Debug_Comment_Decl);
+
+ pragma Inline (New_Type_Decl);
+ pragma Inline (New_Const_Decl);
+
+ pragma Inline (Start_Const_Value);
+ pragma Inline (Finish_Const_Value);
+ pragma Inline (New_Var_Decl);
+
+ pragma Inline (New_Obj);
+ pragma Inline (Start_Function_Decl);
+ pragma Inline (Start_Procedure_Decl);
+ pragma Inline (New_Interface_Decl);
+ pragma Inline (Finish_Subprogram_Decl);
+ pragma Inline (Start_Subprogram_Body);
+ pragma Inline (Finish_Subprogram_Body);
+
+ pragma Inline (New_Debug_Line_Stmt);
+ pragma Inline (New_Debug_Comment_Stmt);
+
+ pragma Inline (Start_Declare_Stmt);
+ pragma Inline (Finish_Declare_Stmt);
+
+ -- Create a function call or a procedure call.
+ pragma Inline (Start_Association);
+ pragma Inline (New_Association);
+ pragma Inline (New_Function_Call);
+ pragma Inline (New_Procedure_Call);
+
+ pragma Inline (New_Assign_Stmt);
+ pragma Inline (New_Return_Stmt);
+ pragma Inline (Start_If_Stmt);
+ pragma Inline (New_Else_Stmt);
+ pragma Inline (Finish_If_Stmt);
+
+ pragma Inline (Start_Loop_Stmt);
+ pragma Inline (Finish_Loop_Stmt);
+ pragma Inline (New_Exit_Stmt);
+ pragma Inline (New_Next_Stmt);
+
+ pragma Inline (Start_Case_Stmt);
+ pragma Inline (Start_Choice);
+ pragma Inline (New_Expr_Choice);
+ pragma Inline (New_Range_Choice);
+ pragma Inline (New_Default_Choice);
+ pragma Inline (Finish_Choice);
+ pragma Inline (Finish_Case_Stmt);
+end Ortho_Mcode;
diff --git a/src/ortho/mcode/ortho_nodes.ads b/src/ortho/mcode/ortho_nodes.ads
new file mode 100644
index 000000000..7a2df3f30
--- /dev/null
+++ b/src/ortho/mcode/ortho_nodes.ads
@@ -0,0 +1,2 @@
+with Ortho_Mcode;
+package Ortho_Nodes renames Ortho_Mcode;