diff options
Diffstat (limited to 'src')
42 files changed, 4061 insertions, 1682 deletions
diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb index 05eed1c..bcca8db 100644 --- a/src/ortho/debug/ortho_debug-disp.adb +++ b/src/ortho/debug/ortho_debug-disp.adb @@ -730,8 +730,10 @@ package body Ortho_Debug.Disp is while El /= O_Cnode_Null loop Set_Mark; Disp_Ident (El.E_Name); - Put (" = "); - Put (Image (El.E_Val)); + if False then + Put (" = "); + Put (Image (El.E_Val)); + end if; El := El.E_Next; exit when El = O_Cnode_Null; Put (", "); diff --git a/src/ortho/mcode/Makefile b/src/ortho/mcode/Makefile index 57c0d75..572c13f 100644 --- a/src/ortho/mcode/Makefile +++ b/src/ortho/mcode/Makefile @@ -9,7 +9,7 @@ all: $(ortho_exec) $(ortho_exec): $(ortho_srcdir)/mcode/ortho_mcode.ads memsegs_c.o force $(GNATMAKE) -o $@ -g -aI$(ortho_srcdir)/mcode -aI$(ortho_srcdir) \ - -aI$(ortho_srcdir)/.. $(GNAT_FLAGS) ortho_code_main \ + -aI$(ortho_srcdir)/.. $(GNAT_FLAGS) -gnatw.A ortho_code_main \ -bargs -E -largs memsegs_c.o #-static memsegs_c.o: $(ortho_srcdir)/mcode/memsegs_c.c diff --git a/src/ortho/mcode/binary_file-elf.adb b/src/ortho/mcode/binary_file-elf.adb index 94f04e3..4732af9 100644 --- a/src/ortho/mcode/binary_file-elf.adb +++ b/src/ortho/mcode/binary_file-elf.adb @@ -18,6 +18,8 @@ with Ada.Text_IO; use Ada.Text_IO; with Elf_Common; with Elf32; +with Elf64; +with Elf_Arch; package body Binary_File.Elf is NUL : Character renames ASCII.NUL; @@ -25,13 +27,14 @@ package body Binary_File.Elf is type Arch_Bool is array (Arch_Kind) of Boolean; Is_Rela : constant Arch_Bool := (Arch_Unknown => False, Arch_X86 => False, + Arch_X86_64 => True, Arch_Sparc => True, Arch_Ppc => True); procedure Write (Fd : GNAT.OS_Lib.File_Descriptor) is use Elf_Common; - use Elf32; + use Elf_Arch; use GNAT.OS_Lib; procedure Xwrite (Data : System.Address; Len : Natural) is @@ -41,22 +44,22 @@ package body Binary_File.Elf is end if; end Xwrite; - procedure Check_File_Pos (Off : Elf32_Off) + procedure Check_File_Pos (Off : Elf_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 " + & Elf_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 + function Sect_Align (V : Elf_Off) return Elf_Off is - Tmp : Elf32_Off; + Tmp : Elf_Off; begin Tmp := V + 2 ** 2 - 1; return Tmp - (Tmp mod 2 ** 2); @@ -65,14 +68,14 @@ package body Binary_File.Elf is type Section_Info_Type is record Sect : Section_Acc; -- Index of the section symbol (in symtab). - Sym : Elf32_Word; + Sym : Elf_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); + type Elf_Shdr_Array is array (Natural range <>) of Elf_Shdr; + Shdr : Elf_Shdr_Array (0 .. 3 + 2 * Nbr_Sections); Nbr_Sect : Natural; Sect : Section_Acc; @@ -83,7 +86,7 @@ package body Binary_File.Elf is Sect_Strtab : constant Natural := 3; Sect_First : constant Natural := 4; - Offset : Elf32_Off; + Offset : Elf_Off; -- Size of a relocation entry. Rel_Size : Natural; @@ -104,87 +107,90 @@ package body Binary_File.Elf is -- Set size of a relocation entry. This avoids severals conditionnal. if Is_Rela (Arch) then - Rel_Size := Elf32_Rela_Size; + Rel_Size := Elf_Rela_Size; else - Rel_Size := Elf32_Rel_Size; + Rel_Size := Elf_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); + Elf_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); + Elf_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)); + Elf_Shdr'(Sh_Name => 11, + Sh_Type => SHT_SYMTAB, + Sh_Flags => 0, + Sh_Addr => 0, + Sh_Offset => 0, + Sh_Size => 0, + Sh_Link => Elf_Word (Sect_Strtab), + Sh_Info => 0, -- FIXME + Sh_Addralign => 4, + Sh_Entsize => Elf_Size (Elf_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); + Elf_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 + -- For Size to word conversion. + pragma Warnings (Off); + Sections (Nbr_Sect) := (Sect => Sect, - Sym => Elf32_Word (Nbr_Symbols)); + Sym => Elf_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)); + Elf_Shdr'(Sh_Name => Elf_Word (Shdr (Sect_Shstrtab).Sh_Size), + Sh_Type => SHT_PROGBITS, + Sh_Flags => 0, + Sh_Addr => Elf_Addr (Sect.Vaddr), + Sh_Offset => 0, + Sh_Size => 0, + Sh_Link => 0, + Sh_Info => 0, + Sh_Addralign => 2 ** Sect.Align, + Sh_Entsize => Elf_Size (Sect.Esize)); if Sect.Data = null then Shdr (Nbr_Sect).Sh_Type := SHT_NOBITS; end if; @@ -217,17 +223,17 @@ package body Binary_File.Elf is 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, + Shdr (Nbr_Sect) := Elf_Shdr' + (Sh_Name => Elf_Word (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_Link => Elf_Word (Sect_Symtab), + Sh_Info => Elf_Word (Nbr_Sect - 1), Sh_Addralign => 4, - Sh_Entsize => Elf32_Word (Rel_Size)); + Sh_Entsize => Elf_Size (Rel_Size)); if Is_Rela (Arch) then Shdr (Nbr_Sect).Sh_Type := SHT_RELA; @@ -241,13 +247,15 @@ package body Binary_File.Elf is Nbr_Sect := Nbr_Sect + 1; end if; Sect := Sect.Next; + + pragma Warnings (On); end loop; -- Lay-out sections. - Offset := Elf32_Off (Elf32_Ehdr_Size); + Offset := Elf_Off (Elf_Ehdr_Size); -- Section table - Offset := Offset + Elf32_Off (Nbr_Sect * Elf32_Shdr_Size); + Offset := Offset + Elf_Off (Nbr_Sect * Elf_Shdr_Size); -- shstrtab. Shdr (Sect_Shstrtab).Sh_Offset := Offset; @@ -259,7 +267,7 @@ package body Binary_File.Elf is 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); + Shdr (Sect.Number).Sh_Size := Elf_Size (Sect.Pc); if Sect.Data /= null then -- Set data offset. Shdr (Sect.Number).Sh_Offset := Offset; @@ -269,13 +277,13 @@ package body Binary_File.Elf is 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); + Elf_Size (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); + Shdr (Sect.Number).Sh_Link := Elf_Word (Sect.Link.Number); end if; end if; end loop; @@ -300,7 +308,7 @@ package body Binary_File.Elf is end case; end loop; - Shdr (Sect_Symtab).Sh_Info := Elf32_Word (Nbr_Symbols); + Shdr (Sect_Symtab).Sh_Info := Elf_Word (Nbr_Symbols); -- Then globals. for I in Symbols.First .. Symbols.Last loop @@ -322,7 +330,7 @@ package body Binary_File.Elf is -- Symtab. Shdr (Sect_Symtab).Sh_Offset := Offset; -- 1 for nul. - Shdr (Sect_Symtab).Sh_Size := Elf32_Word (Nbr_Symbols * Elf32_Sym_Size); + Shdr (Sect_Symtab).Sh_Size := Elf_Size (Nbr_Symbols * Elf_Sym_Size); Offset := Offset + Shdr (Sect_Symtab).Sh_Size; @@ -364,49 +372,55 @@ package body Binary_File.Elf is end loop; Shdr (Sect_Strtab).Sh_Size := - Shdr (Sect_Strtab).Sh_Size + Elf32_Word (Len); + Shdr (Sect_Strtab).Sh_Size + Elf_Size (Len); end; -- Write file header. declare - Ehdr : Elf32_Ehdr; + Ehdr : Elf_Ehdr; begin Ehdr := (E_Ident => (EI_MAG0 => ELFMAG0, EI_MAG1 => ELFMAG1, EI_MAG2 => ELFMAG2, EI_MAG3 => ELFMAG3, - EI_CLASS => ELFCLASS32, + EI_CLASS => ELFCLASSNONE, 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_Version => Elf_Word (EV_CURRENT), E_Entry => 0, E_Phoff => 0, - E_Shoff => Elf32_Off (Elf32_Ehdr_Size), + E_Shoff => Elf_Off (Elf_Ehdr_Size), E_Flags => 0, - E_Ehsize => Elf32_Half (Elf32_Ehdr_Size), + E_Ehsize => Elf_Half (Elf_Ehdr_Size), E_Phentsize => 0, E_Phnum => 0, - E_Shentsize => Elf32_Half (Elf32_Shdr_Size), - E_Shnum => Elf32_Half (Nbr_Sect), + E_Shentsize => Elf_Half (Elf_Shdr_Size), + E_Shnum => Elf_Half (Nbr_Sect), E_Shstrndx => 1); case Arch is when Arch_X86 => Ehdr.E_Ident (EI_DATA) := ELFDATA2LSB; + Ehdr.E_Ident (EI_CLASS) := ELFCLASS32; Ehdr.E_Machine := EM_386; + when Arch_X86_64 => + Ehdr.E_Ident (EI_DATA) := ELFDATA2LSB; + Ehdr.E_Ident (EI_CLASS) := ELFCLASS64; + Ehdr.E_Machine := EM_X86_64; when Arch_Sparc => Ehdr.E_Ident (EI_DATA) := ELFDATA2MSB; + Ehdr.E_Ident (EI_CLASS) := ELFCLASS32; Ehdr.E_Machine := EM_SPARC; when others => raise Program_Error; end case; - Xwrite (Ehdr'Address, Elf32_Ehdr_Size); + Xwrite (Ehdr'Address, Elf_Ehdr_Size); end; -- Write shdr. - Xwrite (Shdr'Address, Nbr_Sect * Elf32_Shdr_Size); + Xwrite (Shdr'Address, Nbr_Sect * Elf_Shdr_Size); -- Write shstrtab Check_File_Pos (Shdr (Sect_Shstrtab).Sh_Offset); @@ -433,7 +447,7 @@ package body Binary_File.Elf is end; -- Pad. declare - Delt : Elf32_Word; + Delt : Elf_Size; Nul_Str : String (1 .. 4) := (others => NUL); begin Delt := Shdr (Sect_Shstrtab).Sh_Size and 3; @@ -452,9 +466,10 @@ package body Binary_File.Elf is end if; declare R : Reloc_Acc; - Rel : Elf32_Rel; - Rela : Elf32_Rela; - S : Elf32_Word; + Rel : Elf_Rel; + Rela : Elf_Rela; + S : Elf_Word; + T : Elf_Word; Nbr_Reloc : Natural; begin R := Sect.First_Reloc; @@ -463,40 +478,54 @@ package body Binary_File.Elf is if R.Done then S := Sections (Get_Section (R.Sym).Number).Sym; else - S := Elf32_Word (Get_Number (R.Sym)); + S := Elf_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); + case Arch is + when Arch_X86_64 => + case R.Kind is + when Reloc_Pc32 => + T := Elf64.R_X86_64_PC32; + when others => + raise Program_Error; + end case; + when Arch_Sparc => + case R.Kind is + when Reloc_Disp22 => + T := Elf32.R_SPARC_WDISP22; + when Reloc_Disp30 => + T := Elf32.R_SPARC_WDISP30; + when Reloc_Hi22 => + T := Elf32.R_SPARC_HI22; + when Reloc_Lo10 => + T := Elf32.R_SPARC_LO10; + when Reloc_32 => + T := Elf32.R_SPARC_32; + when Reloc_Ua_32 => + T := Elf32.R_SPARC_UA32; + when others => + raise Program_Error; + end case; when others => raise Program_Error; end case; Rela.R_Addend := 0; - Rela.R_Offset := Elf32_Addr (R.Addr); - Xwrite (Rela'Address, Elf32_Rela_Size); + Rela.R_Offset := Elf_Addr (R.Addr); + Rela.R_Info := Elf_R_Info (S, T); + Xwrite (Rela'Address, Elf_Rela_Size); else case R.Kind is when Reloc_32 => - Rel.R_Info := Elf32_R_Info (S, R_386_32); + T := Elf32.R_386_32; when Reloc_Pc32 => - Rel.R_Info := Elf32_R_Info (S, R_386_PC32); + T := Elf32.R_386_PC32; when others => raise Program_Error; end case; - Rel.R_Offset := Elf32_Addr (R.Addr); - Xwrite (Rel'Address, Elf32_Rel_Size); + Rel.R_Offset := Elf_Addr (R.Addr); + Rela.R_Info := Elf_R_Info (S, T); + Xwrite (Rel'Address, Elf_Rel_Size); end if; Nbr_Reloc := Nbr_Reloc + 1; R := R.Sect_Next; @@ -511,22 +540,22 @@ package body Binary_File.Elf is -- Write symbol table. Check_File_Pos (Shdr (Sect_Symtab).Sh_Offset); declare - Str_Off : Elf32_Word; + Str_Off : Elf_Off; procedure Gen_Sym (S : Symbol) is - Sym : Elf32_Sym; - Bind : Elf32_Uchar; - Typ : Elf32_Uchar; + Sym : Elf_Sym; + Bind : Elf_Uchar; + Typ : Elf_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); + Sym := Elf_Sym'(St_Name => Elf_Word (Str_Off), + St_Value => Elf_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); + Sym.St_Shndx := Elf_Half (Get_Section (S).Number); end if; case Get_Scope (S) is when Sym_Private @@ -546,48 +575,37 @@ package body Binary_File.Elf is Bind := STB_GLOBAL; Typ := STT_NOTYPE; end case; - Sym.St_Info := Elf32_St_Info (Bind, Typ); + Sym.St_Info := Elf_St_Info (Bind, Typ); - Xwrite (Sym'Address, Elf32_Sym_Size); + Xwrite (Sym'Address, Elf_Sym_Size); - Str_Off := Str_Off + Elf32_Off (Get_Symbol_Name_Length (S) + 1); + Str_Off := Str_Off + Elf_Off (Get_Symbol_Name_Length (S) + 1); end Gen_Sym; - Sym : Elf32_Sym; + Sym : Elf_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); + Sym := Elf_Sym'(St_Name => 0, + St_Value => 0, + St_Size => 0, + St_Info => 0, + St_Other => 0, + St_Shndx => SHN_UNDEF); + Xwrite (Sym'Address, Elf_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); + Sym := Elf_Sym'(St_Name => 0, + St_Value => 0, + St_Size => 0, + St_Info => Elf_St_Info (STB_LOCAL, STT_SECTION), + St_Other => 0, + St_Shndx => Elf_Half (Sect.Number)); + Xwrite (Sym'Address, Elf_Sym_Size); Sect := Sect.Next; end loop; @@ -626,13 +644,6 @@ package body Binary_File.Elf is 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 diff --git a/src/ortho/mcode/binary_file-macho.adb b/src/ortho/mcode/binary_file-macho.adb index dbfc882..be5b16f 100644 --- a/src/ortho/mcode/binary_file-macho.adb +++ b/src/ortho/mcode/binary_file-macho.adb @@ -16,6 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Macho; use Macho; +with Macho_Arch32; use Macho_Arch32; package body Binary_File.Macho is procedure Write (Fd : GNAT.OS_Lib.File_Descriptor) @@ -72,8 +73,8 @@ package body Binary_File.Macho is end record; type Section_Info_Array is array (Natural range <>) of Section_Info_Type; Sects_Info : Section_Info_Array (1 .. Nbr_Sections); - type Section_32_Array is array (Natural range <>) of Section_32; - Sects_Hdr : Section_32_Array (1 .. Nbr_Sections); + type Section_Array is array (Natural range <>) of Section; + Sects_Hdr : Section_Array (1 .. Nbr_Sections); Nbr_Sect : Natural; Sect : Section_Acc; @@ -109,10 +110,10 @@ package body Binary_File.Macho is end loop; -- Set sections offset. - Sizeof_Cmds := Lc_Size + Segment_Command_32_Size - + Nbr_Sect * Section_32_Size + Sizeof_Cmds := Lc_Size + Segment_Command_Size + + Nbr_Sect * Section_Size + Lc_Size + Symtab_Command_Size; - File_Offset := Header_32_Size + Sizeof_Cmds; + File_Offset := Header_Size + Sizeof_Cmds; Seg_Offset := File_Offset; for I in 1 .. Nbr_Sect loop Sect := Sects_Info (I).Sect; @@ -141,49 +142,58 @@ package body Binary_File.Macho is end if; end loop; - File_Offset := File_Offset + Nbr_Symbols * Nlist_32_Size; + File_Offset := File_Offset + Nbr_Symbols * Nlist_Size; Strtab_Offset := File_Offset; -- Write file header. declare - Hdr : Header_32; + Hdr : Header; + Cputype : Unsigned_32; begin + case Arch is + when Arch_X86 => + Cputype := Cputype_I386; + when Arch_X86_64 => + Cputype := Cputype_I386 + Cpu_Arch_64; + when others => + raise Program_Error; + end case; Hdr := (Magic => Magic, - Cputype => Cputype_I386, + Cputype => Cputype, Cpusubtype => Cpusubtype_I386_All, Filetype => Mh_Object, Ncmds => 2, Sizeofcmds => Unsigned_32 (Sizeof_Cmds), - Flags => 0); - Xwrite (Hdr'Address, Header_32_Size); + others => 0); + Xwrite (Hdr'Address, Header_Size); end; -- Write segment and section commands. declare Lc : Load_Command; - Seg : Segment_Command_32; + Seg : Segment_Command; begin - Lc := (Cmd => Lc_Segment_32, - Cmdsize => Unsigned_32 (Lc_Size + Segment_Command_32_Size - + Nbr_Sect * Section_32_Size)); + Lc := (Cmd => Lc_Segment, + Cmdsize => Unsigned_32 (Lc_Size + Segment_Command_Size + + Nbr_Sect * Section_Size)); Xwrite (Lc'Address, Lc_Size); Seg := (Segname => (others => ASCII.NUL), Vmaddr => 0, Vmsize => 0, -- FIXME - Fileoff => Unsigned_32 (Seg_Offset), - Filesize => Unsigned_32 (Symtab_Offset - Seg_Offset), + Fileoff => Addr_T (Seg_Offset), + Filesize => Addr_T (Symtab_Offset - Seg_Offset), Maxprot => 7, -- rwx Initprot => 7, Nsects => Unsigned_32 (Nbr_Sect), Flags => 0); - Xwrite (Seg'Address, Segment_Command_32_Size); + Xwrite (Seg'Address, Segment_Command_Size); end; -- Write section headers. for I in 1 .. Nbr_Sect loop Sect := Sects_Info (I).Sect; declare - Hdr : Section_32 renames Sects_Hdr (I); + Hdr : Section renames Sects_Hdr (I); Secname_Raw : constant String := Sect.Name.all; subtype S_Type is String (1 .. Secname_Raw'Length); Secname : S_Type renames Secname_Raw; @@ -208,15 +218,15 @@ package body Binary_File.Macho is Fill_Name (Hdr.Sectname, Secname); Fill_Name (Hdr.Segname, ""); end if; - Hdr.Addr := Unsigned_32 (Sect.Vaddr); - Hdr.Size := Unsigned_32 (Sect.Pc); + Hdr.Addr := Addr_T (Sect.Vaddr); + Hdr.Size := Addr_T (Sect.Pc); Hdr.Align := Unsigned_32 (Sect.Align); Hdr.Reloff := 0; Hdr.Nreloc := 0; Hdr.Flags := 0; Hdr.Reserved1 := 0; Hdr.Reserved2 := 0; - Xwrite (Hdr'Address, Section_32_Size); + Xwrite (Hdr'Address, Section_Size); end; end loop; @@ -300,13 +310,13 @@ package body Binary_File.Macho is procedure Write_Symbol (S : Symbol) is - Sym : Nlist_32; + Sym : Nlist; begin Sym := (N_Strx => Unsigned_32 (Str_Offset), N_Type => 0, N_Sect => 0, N_Desc => 0, - N_Value => Unsigned_32 (Get_Symbol_Value (S))); + N_Value => Addr_T (Get_Symbol_Value (S))); Str_Offset := Str_Offset + Get_Symbol_Name_Length (S) + 1; if Get_Scope (S) = Sym_Undef then Sym.N_Type := N_Undf; @@ -317,10 +327,9 @@ package body Binary_File.Macho is Sym.N_Type := N_Sect; end if; Sym.N_Sect := Unsigned_8 (Get_Section (S).Number); - Sym.N_Value := - Sym.N_Value + Unsigned_32 (Get_Section (S).Vaddr); + Sym.N_Value := Sym.N_Value + Addr_T (Get_Section (S).Vaddr); end if; - Xwrite (Sym'Address, Nlist_32_Size); + Xwrite (Sym'Address, Nlist_Size); end Write_Symbol; procedure Write_String (Sym : Symbol) diff --git a/src/ortho/mcode/binary_file-memory.adb b/src/ortho/mcode/binary_file-memory.adb index c9bb8ae..99789c6 100644 --- a/src/ortho/mcode/binary_file-memory.adb +++ b/src/ortho/mcode/binary_file-memory.adb @@ -21,17 +21,60 @@ package body Binary_File.Memory is -- Absolute section. Sect_Abs : Section_Acc; + -- PLT section (for x86-64). + Sect_Plt : Section_Acc; + procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address) is begin - Set_Symbol_Value (Sym, To_Pc_Type (Addr)); + if Arch = Arch_X86_64 and then Is_Symbol_Code (Sym) then + -- Branches are limited on x86-64 to a 32 bit offset. Create a + -- trampoline so that functions created outside of the module could + -- be reached using the standard ABI. + -- + -- This works only for code, not for data. Therefore we assume that + -- data symbols are correctly handled. + declare + V : Unsigned_64; + Pc : constant Pc_Type := Sect_Plt.Pc; + begin + Set_Current_Section (Sect_Plt); + Prealloc (16); + + -- Emit: movabs $ADDR, %r11 + V := Unsigned_64 (To_Pc_Type (Addr)); + Sect_Plt.Data (Pc + 0) := 16#49#; + Sect_Plt.Data (Pc + 1) := 16#BB#; + for I in Pc_Type range 0 .. 7 loop + Sect_Plt.Data (Pc + 2 + I) := Byte (V and 16#ff#); + V := Shift_Right (V, 8); + end loop; + + -- Emit: jmp *%r11 + Sect_Plt.Data (Pc + 10) := 16#41#; + Sect_Plt.Data (Pc + 11) := 16#FF#; + Sect_Plt.Data (Pc + 12) := 16#E3#; + + Sect_Plt.Pc := Pc + 13; + Set_Symbol_Value (Sym, Pc); + Set_Section (Sym, Sect_Plt); + end; + else + Set_Symbol_Value (Sym, To_Pc_Type (Addr)); + Set_Section (Sym, Sect_Abs); + end if; + + -- Symbol is not anymore undefined. 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; + + if Arch = Arch_X86_64 then + Create_Section (Sect_Plt, ".plt", Section_Exec); + end if; end Write_Memory_Init; procedure Write_Memory_Relocate (Error : out Boolean) diff --git a/src/ortho/mcode/binary_file.adb b/src/ortho/mcode/binary_file.adb index a9463ba..c0bc102 100644 --- a/src/ortho/mcode/binary_file.adb +++ b/src/ortho/mcode/binary_file.adb @@ -114,6 +114,11 @@ package body Binary_File is return Get_Scope (Sym) = Sym_Local; end S_Local; + function Is_Symbol_Code (Sym : Symbol) return Boolean is + begin + return Symbols.Table (Sym).Code; + end Is_Symbol_Code; + procedure Create_Section (Sect : out Section_Acc; Name : String; Flags : Section_Flags) is @@ -264,12 +269,14 @@ package body Binary_File is return Sect.Pc; end Get_Pc; - procedure Prealloc (L : Pc_Type) is begin Sect_Prealloc (Cur_Sect, L); end Prealloc; + -- Reloc to be adjusted at end_insn. + Pcrel_Reloc : Reloc_Acc := null; + procedure Start_Insn is begin -- Check there is enough memory for the next instruction. @@ -322,6 +329,11 @@ package body Binary_File is Len : Natural; Insn_Len : Natural; begin + if Pcrel_Reloc /= null then + Pcrel_Reloc.Neg_Addend := Cur_Sect.Pc - Pcrel_Reloc.Addr; + Pcrel_Reloc := null; + end if; + --if Insn_Pc = 0 then -- -- start_insn was not called. -- raise Program_Error; @@ -351,65 +363,23 @@ package body Binary_File is Cur_Sect.Insn_Pc := 0; end End_Insn; - procedure Gen_B8 (B : Byte) is + procedure Gen_8 (B : Byte) is begin Cur_Sect.Data (Cur_Sect.Pc) := B; Cur_Sect.Pc := Cur_Sect.Pc + 1; - end Gen_B8; + end Gen_8; - procedure Gen_B16 (B0, B1 : Byte) is + procedure Gen_8 (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; + end Gen_8; - 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 + procedure Write_8 (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; + end Write_8; procedure Write_16 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32) is @@ -429,6 +399,24 @@ package body Binary_File is Sect.Data (Pc + 0 .. Pc + 3) := To_B4 (B); end Write_32; + procedure Write_64 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_64) + is + subtype B8 is Byte_Array_Base (0 .. 7); + function To_B8 is new Ada.Unchecked_Conversion + (Source => Unsigned_64, Target => B8); + begin + Sect.Data (Pc + 0 .. Pc + 7) := To_B8 (B); + end Write_64; + + procedure Write_Addr (Sect : Section_Acc; Pc : Pc_Type; B : Pc_Type) + is + subtype BPC is Byte_Array_Base (0 .. Pc_Type_Sizeof - 1); + function To_BPC is new Ada.Unchecked_Conversion + (Source => Pc_Type, Target => BPC); + begin + Sect.Data (Pc + 0 .. Pc + Pc_Type_Sizeof - 1) := To_BPC (B); + end Write_Addr; + procedure Gen_16 (B : Unsigned_32) is begin Write_16 (Cur_Sect, Cur_Sect.Pc, B); @@ -441,94 +429,73 @@ package body Binary_File is 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 + function Read_32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 + is + subtype B4 is Byte_Array_Base (0 .. 3); + function From_B4 is new Ada.Unchecked_Conversion + (Source => B4, Target => Unsigned_32); begin - if Pc + 4 > Get_Current_Pc then - raise Program_Error; - end if; - Write_Le32 (Cur_Sect, Pc, V); - end Patch_Le32; + return From_B4 (Sect.Data (Pc + 0 .. Pc + 3)); + end Read_32; - procedure Patch_Be32 (Pc : Pc_Type; V : Unsigned_32) is + function Read_Addr (Sect : Section_Acc; Pc : Pc_Type) return Pc_Type + is + subtype BPC is Byte_Array_Base (0 .. Pc_Type_Sizeof - 1); + function From_BPC is new Ada.Unchecked_Conversion + (Source => BPC, Target => Pc_Type); begin - if Pc + 4 > Get_Current_Pc then - raise Program_Error; - end if; - Write_Be32 (Cur_Sect, Pc, V); - end Patch_Be32; + return From_BPC (Sect.Data (Pc + 0 .. Pc + Pc_Type_Sizeof - 1)); + end Read_Addr; - procedure Patch_Be16 (Pc : Pc_Type; V : Unsigned_32) is + procedure Add_32 (Sect : Section_Acc; 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; + Write_32 (Sect, Pc, V + Read_32 (Sect, Pc)); + end Add_32; - procedure Patch_B8 (Pc : Pc_Type; V : Unsigned_8) is + procedure Add_Addr (Sect : Section_Acc; Pc : Pc_Type; V : Pc_Type) is begin - if Pc >= Get_Current_Pc then - raise Program_Error; - end if; - Write_B8 (Cur_Sect, Pc, V); - end Patch_B8; + Write_Addr (Sect, Pc, V + Read_Addr (Sect, Pc)); + end Add_Addr; procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32) is begin - if Pc + 4 > Get_Current_Pc then - raise Program_Error; - end if; + pragma Assert (Pc + 4 <= Get_Current_Pc); Write_32 (Cur_Sect, Pc, V); end Patch_32; - procedure Gen_Le32 (B : Unsigned_32) is + procedure Patch_16 (Pc : Pc_Type; V : Unsigned_32) is begin - Write_Le32 (Cur_Sect, Cur_Sect.Pc, B); - Cur_Sect.Pc := Cur_Sect.Pc + 4; - end Gen_Le32; + pragma Assert (Pc + 2 <= Get_Current_Pc); + Write_16 (Cur_Sect, Pc, V); + end Patch_16; - procedure Gen_Be32 (B : Unsigned_32) is + procedure Patch_8 (Pc : Pc_Type; V : Unsigned_8) is begin - Write_Be32 (Cur_Sect, Cur_Sect.Pc, B); - Cur_Sect.Pc := Cur_Sect.Pc + 4; - end Gen_Be32; + pragma Assert (Pc + 1 <= Get_Current_Pc); + Write_8 (Cur_Sect, Pc, V); + end Patch_8; - procedure Gen_Data_Le8 (B : Unsigned_32) is + procedure Gen_64 (B : Unsigned_64) is + begin + Write_64 (Cur_Sect, Cur_Sect.Pc, B); + Cur_Sect.Pc := Cur_Sect.Pc + 8; + end Gen_64; + + procedure Gen_Data_8 (B : Unsigned_8) is begin if Dump_Asm then - Put_Line (HT & ".byte 0x" & Hex_Image (Unsigned_8 (B))); + Put_Line (HT & ".byte 0x" & Hex_Image (B)); end if; - Gen_Le8 (B); - end Gen_Data_Le8; + Gen_8 (Byte (B)); + end Gen_Data_8; - procedure Gen_Data_Le16 (B : Unsigned_32) is + procedure Gen_Data_16 (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; + Gen_16 (B); + end Gen_Data_16; procedure Gen_Data_32 (Sym : Symbol; Offset : Integer_32) is begin @@ -554,13 +521,22 @@ package body Binary_File is end case; end Gen_Data_32; - function Create_Symbol (Name : O_Ident) return Symbol + function To_Unsigned_32 (Off : Pc_Type) return Unsigned_32 is + begin + -- if Off >= 16#8000_0000# and Off < 16#ffff_ffff_8000_0000# then + -- raise Constraint_Error; + -- end if; + return Unsigned_32 (Off and 16#ffff_ffff#); + end To_Unsigned_32; + + function Create_Symbol (Name : O_Ident; Code : Boolean) return Symbol is begin Symbols.Append (Symbol_Type'(Section => null, Value => 0, Scope => Sym_Undef, Used => False, + Code => Code, Name => Name, Relocs => null, Number => 0)); @@ -575,6 +551,7 @@ package body Binary_File is Value => 0, Scope => Sym_Local, Used => False, + Code => False, -- Don't care. Name => O_Ident_Nul, Relocs => null, Number => Last_Label)); @@ -697,17 +674,22 @@ package body Binary_File is end if; end Set_Symbol_Pc; - procedure Add_Reloc (Sym : Symbol; Kind : Reloc_Kind) + function Add_Reloc (Sym : Symbol; Kind : Reloc_Kind) return Reloc_Acc is Reloc : Reloc_Acc; begin Reloc := new Reloc_Type'(Kind => Kind, Done => False, + Neg_Addend => 0, Sym_Next => Get_Relocs (Sym), Sect_Next => null, Addr => Cur_Sect.Pc, Sym => Sym); + + -- Add reloc to the relocations list of SYM. Set_Relocs (Sym, Reloc); + + -- Add reloc to the relocations list of CUR_SECT. if Cur_Sect.First_Reloc = null then Cur_Sect.First_Reloc := Reloc; else @@ -715,27 +697,48 @@ package body Binary_File is end if; Cur_Sect.Last_Reloc := Reloc; Cur_Sect.Nbr_Relocs := Cur_Sect.Nbr_Relocs + 1; + + return Reloc; end Add_Reloc; - procedure Gen_X86_Pc32 (Sym : Symbol) + procedure Add_Reloc (Sym : Symbol; Kind : Reloc_Kind) is + Res : Reloc_Acc; + pragma Unreferenced (Res); + begin + Res := Add_Reloc (Sym, Kind); + end Add_Reloc; + + function Conv is new Ada.Unchecked_Conversion + (Source => Integer_32, Target => Unsigned_32); + + procedure Gen_X86_Pc32 (Sym : Symbol; Off : Unsigned_32) is begin - Add_Reloc (Sym, Reloc_Pc32); - Gen_Le32 (16#ff_ff_ff_fc#); + -- On X86, displacements (EIP/RIP relative offsets) are relative to the + -- PC of the following instruction. For jmp or jcc, the instruction + -- ends just after the disp32, but for x86-64 RIP relative addressing, + -- the length of the instruction is not known. So this relocation will + -- be adjusted at the end of the instruction. + + -- Handle only one PCrel relocation per instruction. + pragma Assert (Pcrel_Reloc = null); + + Pcrel_Reloc := Add_Reloc (Sym, Reloc_Pc32); + Gen_32 (Off); end Gen_X86_Pc32; procedure Gen_Sparc_Disp22 (W : Unsigned_32; Sym : Symbol) is begin Add_Reloc (Sym, Reloc_Disp22); - Gen_Be32 (W); + Gen_32 (W); end Gen_Sparc_Disp22; procedure Gen_Sparc_Disp30 (W : Unsigned_32; Sym : Symbol) is begin Add_Reloc (Sym, Reloc_Disp30); - Gen_Be32 (W); + Gen_32 (W); end Gen_Sparc_Disp30; procedure Gen_Sparc_Hi22 (W : Unsigned_32; @@ -744,7 +747,7 @@ package body Binary_File is pragma Unreferenced (Off); begin Add_Reloc (Sym, Reloc_Hi22); - Gen_Be32 (W); + Gen_32 (W); end Gen_Sparc_Hi22; procedure Gen_Sparc_Lo10 (W : Unsigned_32; @@ -753,18 +756,35 @@ package body Binary_File is pragma Unreferenced (Off); begin Add_Reloc (Sym, Reloc_Lo10); - Gen_Be32 (W); + Gen_32 (W); end Gen_Sparc_Lo10; - function Conv is new Ada.Unchecked_Conversion - (Source => Integer_32, Target => Unsigned_32); + procedure Gen_Addr (Offset : Integer_32) is + begin + if Pc_Type'Size = 32 then + Gen_32 (Conv (Offset)); + elsif Pc_Type'Size = 64 then + Gen_64 (Unsigned_64 (Conv (Offset))); + else + raise Program_Error; + end if; + end Gen_Addr; + + procedure Gen_Abs (Sym : Symbol; Offset : Integer_32) is + begin + if Sym /= Null_Symbol then + Add_Reloc (Sym, Reloc_Abs); + end if; + Gen_Addr (Offset); + end Gen_Abs; procedure Gen_X86_32 (Sym : Symbol; Offset : Integer_32) is begin + pragma Assert (Arch = Arch_X86); if Sym /= Null_Symbol then Add_Reloc (Sym, Reloc_32); end if; - Gen_Le32 (Conv (Offset)); + Gen_32 (Conv (Offset)); end Gen_X86_32; procedure Gen_Sparc_32 (Sym : Symbol; Offset : Integer_32) is @@ -772,30 +792,24 @@ package body Binary_File is if Sym /= Null_Symbol then Add_Reloc (Sym, Reloc_32); end if; - Gen_Be32 (Conv (Offset)); + Gen_32 (Conv (Offset)); end Gen_Sparc_32; - procedure Gen_Sparc_Ua_32 (Sym : Symbol; Offset : Integer_32) - is - pragma Unreferenced (Offset); + procedure Gen_Ua_32 (Sym : Symbol) is begin if Sym /= Null_Symbol then Add_Reloc (Sym, Reloc_Ua_32); end if; - Gen_Be32 (0); - end Gen_Sparc_Ua_32; + Gen_32 (0); + end Gen_Ua_32; - procedure Gen_Ua_32 (Sym : Symbol; Offset : Integer_32) is + procedure Gen_Ua_Addr (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; + if Sym /= Null_Symbol then + Add_Reloc (Sym, Reloc_Ua_Addr); + end if; + Gen_Addr (Offset); + end Gen_Ua_Addr; procedure Gen_Ppc_24 (V : Unsigned_32; Sym : Symbol) is @@ -809,19 +823,19 @@ package body Binary_File is 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) + procedure Write_Left_32 (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; + W := Read_32 (Sect, Addr); + Write_32 (Sect, Addr, (W and not Mask) or (Val and Mask)); + end Write_Left_32; procedure Set_Wdisp (Sect : Section_Acc; Addr : Pc_Type; @@ -844,41 +858,45 @@ package body Binary_File is end if; end if; -- Write value. - Write_Left_Be32 (Sect, Addr, Size, D / 4); + Write_Left_32 (Sect, Addr, Size, D / 4); end Set_Wdisp; - procedure Do_Reloc (Kind : Reloc_Kind; - Sect : Section_Acc; Addr : Pc_Type; Sym : Symbol) + procedure Apply_Reloc (Sect : Section_Acc; Reloc : Reloc_Acc) is + Addr : constant Pc_Type := Reloc.Addr; + Sym : constant Symbol := Reloc.Sym; begin - if Get_Scope (Sym) = Sym_Undef then - raise Program_Error; - end if; + pragma Assert (Get_Scope (Sym) /= Sym_Undef); - case Kind is + case Reloc.Kind is when Reloc_32 => - Add_Le32 (Sect, Addr, Unsigned_32 (Get_Symbol_Vaddr (Sym))); + Add_32 (Sect, Addr, Unsigned_32 (Get_Symbol_Vaddr (Sym))); + + when Reloc_Abs + | Reloc_Ua_Addr => + Add_Addr (Sect, Addr, Get_Symbol_Vaddr (Sym)); when Reloc_Pc32 => - Add_Le32 (Sect, Addr, - Unsigned_32 (Get_Symbol_Vaddr (Sym) - - (Sect.Vaddr + Addr))); + Add_32 (Sect, Addr, + To_Unsigned_32 (Get_Symbol_Vaddr (Sym) + - (Sect.Vaddr + Addr) + - Reloc.Neg_Addend)); 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)); + Write_Left_32 (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))); + Write_Left_32 (Sect, Addr, 10, + Unsigned_32 (Get_Symbol_Vaddr (Sym))); when Reloc_Ua_32 => - Write_Be32 (Sect, Addr, Unsigned_32 (Get_Symbol_Vaddr (Sym))); + Write_32 (Sect, Addr, Unsigned_32 (Get_Symbol_Vaddr (Sym))); when Reloc_Ppc_Addr24 => raise Program_Error; end case; - end Do_Reloc; + end Apply_Reloc; function Is_Reloc_Relative (Reloc : Reloc_Acc) return Boolean is begin @@ -892,11 +910,6 @@ package body Binary_File is 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; @@ -908,7 +921,7 @@ package body Binary_File is 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); + Apply_Reloc (Sect, Rel); Rel.Done := True; if Get_Section (Rel.Sym) = Sect diff --git a/src/ortho/mcode/binary_file.ads b/src/ortho/mcode/binary_file.ads index da8341b..d583f2d 100644 --- a/src/ortho/mcode/binary_file.ads +++ b/src/ortho/mcode/binary_file.ads @@ -43,8 +43,11 @@ package Binary_File is type Pc_Type is mod System.Memory_Size; Null_Pc : constant Pc_Type := 0; + -- Number of bytes in a word. + Pc_Type_Sizeof : constant := Pc_Type'Size / 8; - type Arch_Kind is (Arch_Unknown, Arch_X86, Arch_Sparc, Arch_Ppc); + type Arch_Kind is + (Arch_Unknown, Arch_X86, Arch_X86_64, Arch_Sparc, Arch_Ppc); Arch : Arch_Kind := Arch_Unknown; -- Dump assembly when generated. @@ -67,7 +70,7 @@ package Binary_File is -- Create an undefined local (anonymous) symbol in the current section. function Create_Local_Symbol return Symbol; - function Create_Symbol (Name : O_Ident) return Symbol; + function Create_Symbol (Name : O_Ident; Code : Boolean) return Symbol; -- Research symbol NAME, very expansive call. -- Return NULL_Symbol if not found. @@ -77,6 +80,9 @@ package Binary_File is function Get_Symbol_Vaddr (Sym : Symbol) return Pc_Type; pragma Inline (Get_Symbol_Vaddr); + -- Return True iff SYM is a code symbol. + function Is_Symbol_Code (Sym : Symbol) return Boolean; + -- Set the value of a symbol. procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean); function Get_Symbol_Value (Sym : Symbol) return Pc_Type; @@ -95,7 +101,7 @@ package Binary_File is 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_X86_Pc32 (Sym : Symbol; Off : Unsigned_32); 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; @@ -103,15 +109,18 @@ package Binary_File is procedure Gen_Sparc_Lo10 (W : Unsigned_32; Sym : Symbol; Off : Unsigned_32); + -- An absolute reloc. + procedure Gen_Abs (Sym : Symbol; Offset : Integer_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); + procedure Gen_Ua_Addr (Sym : Symbol; Offset : Integer_32); + procedure Gen_Ua_32 (Sym : Symbol); -- Start/finish an instruction in the current section. procedure Start_Insn; @@ -120,29 +129,25 @@ package Binary_File is 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_8 (B : Byte); + procedure Gen_8 (B0, B1 : Byte); procedure Gen_16 (B : Unsigned_32); procedure Gen_32 (B : Unsigned_32); + procedure Gen_64 (B : Unsigned_64); -- 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_8 (B : Unsigned_8); + procedure Gen_Data_16 (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_8 (Pc : Pc_Type; V : Unsigned_8); + procedure Patch_16 (Pc : Pc_Type; V : Unsigned_32); procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32); + function To_Unsigned_32 (Off : Pc_Type) return Unsigned_32; + -- Binary writers: -- Set ERROR in case of error (undefined symbol). @@ -158,9 +163,12 @@ private type String_Acc is access String; --type Section_Flags is new Unsigned_32; + subtype Pc_Type8 is Pc_Type range 0 .. 255; + -- Relocations. type Reloc_Kind is (Reloc_32, Reloc_Pc32, - Reloc_Ua_32, + Reloc_Abs, + Reloc_Ua_32, Reloc_Ua_Addr, Reloc_Disp22, Reloc_Disp30, Reloc_Hi22, Reloc_Lo10, Reloc_Ppc_Addr24); @@ -170,6 +178,8 @@ private Kind : Reloc_Kind; -- If true, the reloc was already applied. Done : Boolean; + -- Negative addend (only for pcrel relocs). + Neg_Addend : Pc_Type8; -- Next in simply linked list. -- next reloc in the section. Sect_Next : Reloc_Acc; @@ -230,12 +240,16 @@ private -- 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; + -- True if the symbol represent code (and therefore could be placed in + -- a PLT). + Code : Boolean; -- Name of the symbol. Name : O_Ident; -- List of relocation made with this symbol. diff --git a/src/ortho/mcode/elf32.adb b/src/ortho/mcode/elf32.adb index ef58fe6..02c9791 100644 --- a/src/ortho/mcode/elf32.adb +++ b/src/ortho/mcode/elf32.adb @@ -16,21 +16,6 @@ -- 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); diff --git a/src/ortho/mcode/elf32.ads b/src/ortho/mcode/elf32.ads index 5afd317..ad9b731 100644 --- a/src/ortho/mcode/elf32.ads +++ b/src/ortho/mcode/elf32.ads @@ -71,13 +71,6 @@ package Elf32 is 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; diff --git a/src/ortho/mcode/elf64.adb b/src/ortho/mcode/elf64.adb new file mode 100644 index 0000000..e13ec6e --- /dev/null +++ b/src/ortho/mcode/elf64.adb @@ -0,0 +1,34 @@ +-- 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. + +package body Elf64 is + function Elf64_R_Sym (I : Elf64_Xword) return Elf64_Word is + begin + return Elf64_Word (Shift_Right (I, 32)); + end Elf64_R_Sym; + + function Elf64_R_Type (I : Elf64_Xword) return Elf64_Word is + begin + return Elf64_Word (I and 16#Ffff_ffff#); + end Elf64_R_Type; + + function Elf64_R_Info (S, T : Elf64_Word) return Elf64_Xword is + begin + return Shift_Left (Elf64_Xword (S), 32) or Elf64_Xword (T); + end Elf64_R_Info; +end Elf64; diff --git a/src/ortho/mcode/elf64.ads b/src/ortho/mcode/elf64.ads index 217e555..e5f188f 100644 --- a/src/ortho/mcode/elf64.ads +++ b/src/ortho/mcode/elf64.ads @@ -87,9 +87,14 @@ package Elf64 is 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; + function Elf64_R_Sym (I : Elf64_Xword) return Elf64_Word; + function Elf64_R_Type (I : Elf64_Xword) return Elf64_Word; + function Elf64_R_Info (S, T : Elf64_Word) return Elf64_Xword; + + -- For x86-64 + R_X86_64_NONE : constant Elf64_Word := 0; + R_X86_64_64 : constant Elf64_Word := 1; + R_X86_64_PC32 : constant Elf64_Word := 2; type Elf64_Phdr is record P_Type : Elf64_Word; diff --git a/src/ortho/mcode/elf_arch.ads b/src/ortho/mcode/elf_arch.ads deleted file mode 100644 index 325c4e5..0000000 --- a/src/ortho/mcode/elf_arch.ads +++ /dev/null @@ -1,2 +0,0 @@ -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 index 5e987b1..e04ee1c 100644 --- a/src/ortho/mcode/elf_arch32.ads +++ b/src/ortho/mcode/elf_arch32.ads @@ -28,10 +28,21 @@ package Elf_Arch32 is subtype Elf_Off is Elf32_Off; subtype Elf_Size is Elf32_Word; + subtype Elf_Addr is Elf32_Addr; 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_Rel_Size : constant Natural := Elf32_Rel_Size; + Elf_Rela_Size : constant Natural := Elf32_Rela_Size; Elf_Arch_Class : constant Elf_Uchar := ELFCLASS32; + + function Elf_R_Sym (I : Elf32_Word) return Elf32_Word + renames Elf32_R_Sym; + function Elf_R_Type (I : Elf32_Word) return Elf32_Word + renames Elf32_R_Type; + function Elf_R_Info (S, T : Elf32_Word) return Elf32_Word + renames Elf32_R_Info; + end Elf_Arch32; diff --git a/src/ortho/mcode/elf_arch64.ads b/src/ortho/mcode/elf_arch64.ads index 504cd66..481b341 100644 --- a/src/ortho/mcode/elf_arch64.ads +++ b/src/ortho/mcode/elf_arch64.ads @@ -28,10 +28,20 @@ package Elf_Arch64 is subtype Elf_Off is Elf64_Off; subtype Elf_Size is Elf64_Xword; + subtype Elf_Addr is Elf64_Addr; 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_Rel_Size : constant Natural := Elf64_Rel_Size; + Elf_Rela_Size : constant Natural := Elf64_Rela_Size; Elf_Arch_Class : constant Elf_Uchar := ELFCLASS64; + + function Elf_R_Sym (I : Elf64_Xword) return Elf_Word + renames Elf64_R_Sym; + function Elf_R_Type (I : Elf64_Xword) return Elf_Word + renames Elf64_R_Type; + function Elf_R_Info (S, T : Elf_Word) return Elf64_Xword + renames Elf64_R_Info; end Elf_Arch64; diff --git a/src/ortho/mcode/elf_common.ads b/src/ortho/mcode/elf_common.ads index 28186d0..f394032 100644 --- a/src/ortho/mcode/elf_common.ads +++ b/src/ortho/mcode/elf_common.ads @@ -46,6 +46,7 @@ package Elf_Common is 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 + EM_X86_64 : constant Elf_Half := 62; -- RESERVED : constant Elf_Half := 11; -- -16 Reserved for future use -- e_version @@ -121,7 +122,6 @@ package Elf_Common is 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#; diff --git a/src/ortho/mcode/macho.ads b/src/ortho/mcode/macho.ads index e080a43..d4630d3 100644 --- a/src/ortho/mcode/macho.ads +++ b/src/ortho/mcode/macho.ads @@ -29,11 +29,26 @@ package Macho is Flags : Unsigned_32; end record; + type Header_64 is record + Magic : Unsigned_32; + Cputype : Unsigned_32; + Cpusubtype : Unsigned_32; + Filetype : Unsigned_32; + Ncmds : Unsigned_32; + Sizeofcmds : Unsigned_32; + Flags : Unsigned_32; + Reserved : Unsigned_32; + end record; + -- Size of Filehdr. Header_32_Size : constant Natural := Header_32'Size / Storage_Unit; + Header_64_Size : constant Natural := Header_64'Size / Storage_Unit; -- Magic numbers. - Magic : constant Unsigned_32 := 16#feed_face#; + Magic_32 : constant Unsigned_32 := 16#feed_face#; + Magic_64 : constant Unsigned_32 := 16#feed_facf#; + + Cpu_Arch_64 : constant Unsigned_32 := 16#0100_0000#; Cputype_I386 : constant Unsigned_32 := 7; Cpusubtype_I386_All : constant Unsigned_32 := 3; @@ -77,6 +92,37 @@ package Macho is end record; Section_32_Size : constant Natural := Section_32'Size / Storage_Unit; + Lc_Segment_64 : constant Unsigned_32 := 16#19#; + type Segment_Command_64 is record + Segname : String (1 .. 16); + Vmaddr : Unsigned_64; + Vmsize : Unsigned_64; + Fileoff : Unsigned_64; + Filesize : Unsigned_64; + Maxprot : Unsigned_32; + Initprot : Unsigned_32; + Nsects : Unsigned_32; + Flags : Unsigned_32; + end record; + Segment_Command_64_Size : constant Natural := + Segment_Command_64'Size / Storage_Unit; + + type Section_64 is record + Sectname : String (1 .. 16); + Segname : String (1 .. 16); + Addr : Unsigned_64; + Size : Unsigned_64; + Offset : Unsigned_32; + Align : Unsigned_32; + Reloff : Unsigned_32; + Nreloc : Unsigned_32; + Flags : Unsigned_32; + Reserved1 : Unsigned_32; + Reserved2 : Unsigned_32; + Reserved3 : Unsigned_32; + end record; + Section_64_Size : constant Natural := Section_64'Size / Storage_Unit; + Lc_Symtab : constant Unsigned_32 := 2; type Symtab_Command is record Symoff : Unsigned_32; @@ -97,6 +143,16 @@ package Macho is Nlist_32_Size : constant Natural := Nlist_32'Size / Storage_Unit; + type Nlist_64 is record + N_Strx : Unsigned_32; + N_Type : Unsigned_8; + N_Sect : Unsigned_8; + N_Desc : Unsigned_16; + N_Value : Unsigned_64; + end record; + + Nlist_64_Size : constant Natural := Nlist_64'Size / Storage_Unit; + N_Undf : constant Unsigned_8 := 16#00#; N_Ext : constant Unsigned_8 := 16#01#; N_Sect : constant Unsigned_8 := 16#0e#; diff --git a/src/ortho/mcode/macho_arch32.ads b/src/ortho/mcode/macho_arch32.ads new file mode 100644 index 0000000..e4270e0 --- /dev/null +++ b/src/ortho/mcode/macho_arch32.ads @@ -0,0 +1,36 @@ +-- Macho definitions. +-- Copyright (C) 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Interfaces; use Interfaces; +with Macho; + +package Macho_Arch32 is + subtype Addr_T is Unsigned_32; + subtype Header is Macho.Header_32; + Header_Size : constant Natural := Macho.Header_32_Size; + Magic : constant Unsigned_32 := Macho.Magic_32; + + Lc_Segment : constant Unsigned_32 := Macho.Lc_Segment_32; + subtype Segment_Command is Macho.Segment_Command_32; + Segment_Command_Size : constant Natural := Macho.Segment_Command_32_Size; + + subtype Section is Macho.Section_32; + Section_Size : constant Natural := Macho.Section_32_Size; + + subtype Nlist is Macho.Nlist_32; + Nlist_Size : constant Natural := Macho.Nlist_32_Size; +end Macho_Arch32; diff --git a/src/ortho/mcode/macho_arch64.ads b/src/ortho/mcode/macho_arch64.ads new file mode 100644 index 0000000..a34ad45 --- /dev/null +++ b/src/ortho/mcode/macho_arch64.ads @@ -0,0 +1,36 @@ +-- Macho definitions. +-- Copyright (C) 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Interfaces; use Interfaces; +with Macho; + +package Macho_Arch64 is + subtype Addr_T is Unsigned_64; + subtype Header is Macho.Header_64; + Header_Size : constant Natural := Macho.Header_64_Size; + Magic : constant Unsigned_32 := Macho.Magic_64; + + Lc_Segment : constant Unsigned_32 := Macho.Lc_Segment_64; + subtype Segment_Command is Macho.Segment_Command_64; + Segment_Command_Size : constant Natural := Macho.Segment_Command_64_Size; + + subtype Section is Macho.Section_64; + Section_Size : constant Natural := Macho.Section_64_Size; + + subtype Nlist is Macho.Nlist_64; + Nlist_Size : constant Natural := Macho.Nlist_64_Size; +end Macho_Arch64; diff --git a/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb index 6e36a07..4522e67 100644 --- a/src/ortho/mcode/ortho_code-consts.adb +++ b/src/ortho/mcode/ortho_code-consts.adb @@ -363,32 +363,33 @@ package body Ortho_Code.Consts is procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) is + Num : constant Uns32 := Get_Type_Subarray_Length (Atype); 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); + El => Val, + Len => Num); 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 + Value : O_Cnode) is begin + pragma Assert (List.Len > 0); + List.Len := List.Len - 1; 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 + Res : out O_Cnode) is begin + pragma Assert (List.Len = 0); Res := List.Res; end Finish_Array_Aggr; diff --git a/src/ortho/mcode/ortho_code-consts.ads b/src/ortho/mcode/ortho_code-consts.ads index 0076bc6..102dc59 100644 --- a/src/ortho/mcode/ortho_code-consts.ads +++ b/src/ortho/mcode/ortho_code-consts.ads @@ -142,6 +142,7 @@ private type O_Array_Aggr_List is record Res : O_Cnode; El : Int32; + Len : Uns32; end record; type O_Record_Aggr_List is record diff --git a/src/ortho/mcode/ortho_code-debug.ads b/src/ortho/mcode/ortho_code-debug.ads index 1eb3652..36aa694 100644 --- a/src/ortho/mcode/ortho_code-debug.ads +++ b/src/ortho/mcode/ortho_code-debug.ads @@ -55,7 +55,7 @@ package Ortho_Code.Debug is -- H: generate high-level instructions. Flag_Debug_Hli : Boolean := False; - -- r: raw dump, do not generate code. + -- d: raw dump, do not generate code. Flag_Debug_Dump : Boolean := False; -- i: disp insns, when generated. diff --git a/src/ortho/mcode/ortho_code-decls.adb b/src/ortho/mcode/ortho_code-decls.adb index 253ea60..8b6d92f 100644 --- a/src/ortho/mcode/ortho_code-decls.adb +++ b/src/ortho/mcode/ortho_code-decls.adb @@ -28,9 +28,9 @@ package body Ortho_Code.Decls is -- Common fields: -- kind: 4 bits -- storage: 2 bits + -- flags (addr, 2): 2 bits -- reg : 8 bits -- depth : 16 bits - -- flags: addr + 9 -- Additionnal fields: -- OD_Type: Id, dtype -- OD_Var: Id, Dtype, symbol @@ -633,6 +633,15 @@ package body Ortho_Code.Decls is use Ada.Text_IO; use Ortho_Ident; use Ortho_Code.Debug.Int32_IO; + + procedure Disp_Decl_Type (Decl : O_Dnode) + is + Dtype : constant O_Tnode := Get_Decl_Type (Decl); + begin + Put (Int32 (Dtype), 0); + Put (", "); + Disp_Mode (Types.Get_Type_Mode (Dtype)); + end Disp_Decl_Type; begin Set_Col (Count (Indent)); Put (Int32 (Decl), 0); @@ -642,13 +651,15 @@ package body Ortho_Code.Decls is Put ("type "); Disp_Decl_Name (Decl); Put (" is "); - Put (Int32 (Get_Decl_Type (Decl)), 0); + Disp_Decl_Type (Decl); when OD_Function => Disp_Decl_Storage (Decl); Put (" function "); Disp_Decl_Name (Decl); Put (" return "); - Put (Int32 (Get_Decl_Type (Decl)), 0); + Disp_Decl_Type (Decl); + Put (" stack: "); + Put (Get_Subprg_Stack (Decl), 0); when OD_Procedure => Disp_Decl_Storage (Decl); Put (" procedure "); @@ -657,17 +668,17 @@ package body Ortho_Code.Decls is Put (" interface "); Disp_Decl_Name (Decl); Put (": "); - Put (Int32 (Get_Decl_Type (Decl)), 0); - Put (", "); - Disp_Mode (Types.Get_Type_Mode (Get_Decl_Type (Decl))); + Disp_Decl_Type (Decl); Put (", offset="); Put (Get_Inter_Offset (Decl), 0); + Put (", reg="); + Put (Image_Reg (Get_Decl_Reg (Decl))); when OD_Const => Disp_Decl_Storage (Decl); Put (" const "); Disp_Decl_Name (Decl); Put (": "); - Put (Int32 (Get_Decl_Type (Decl)), 0); + Disp_Decl_Type (Decl); when OD_Const_Val => Put ("constant "); Disp_Decl_Name (Get_Val_Decl (Decl)); @@ -677,7 +688,7 @@ package body Ortho_Code.Decls is Put ("local "); Disp_Decl_Name (Decl); Put (": "); - Put (Int32 (Get_Decl_Type (Decl)), 0); + Disp_Decl_Type (Decl); Put (", offset="); Put (Get_Inter_Offset (Decl), 0); when OD_Var => @@ -685,7 +696,7 @@ package body Ortho_Code.Decls is Put (" var "); Disp_Decl_Name (Decl); Put (": "); - Put (Int32 (Get_Decl_Type (Decl)), 0); + Disp_Decl_Type (Decl); when OD_Body => Put ("body of "); Put (Int32 (Get_Body_Decl (Decl)), 0); diff --git a/src/ortho/mcode/ortho_code-dwarf.adb b/src/ortho/mcode/ortho_code-dwarf.adb index 521ab85..48dddda 100644 --- a/src/ortho/mcode/ortho_code-dwarf.adb +++ b/src/ortho/mcode/ortho_code-dwarf.adb @@ -58,9 +58,9 @@ package body Ortho_Code.Dwarf is begin Prealloc (Str'Length + 1); for I in Str'Range loop - Gen_B8 (Character'Pos (Str (I))); + Gen_8 (Character'Pos (Str (I))); end loop; - Gen_B8 (0); + Gen_8 (0); end Gen_String_Nul; procedure Gen_Sleb128 (V : Int32) @@ -78,10 +78,10 @@ package body Ortho_Code.Dwarf is if (V2 = 0 and (B and 16#40#) = 0) or (V2 = -1 and (B and 16#40#) /= 0) then - Gen_B8 (B); + Gen_8 (B); exit; else - Gen_B8 (B or 16#80#); + Gen_8 (B or 16#80#); V1 := V2; end if; end loop; @@ -96,9 +96,9 @@ package body Ortho_Code.Dwarf is B := Byte (V1 and 16#7f#); V1 := Shift_Right (V1, 7); if V1 /= 0 then - Gen_B8 (B or 16#80#); + Gen_8 (B or 16#80#); else - Gen_B8 (B); + Gen_8 (B); exit; end if; end loop; @@ -130,7 +130,7 @@ package body Ortho_Code.Dwarf is Prealloc (32); if Cur_File /= Last_File then - Gen_B8 (Byte (DW_LNS_Set_File)); + Gen_8 (Byte (DW_LNS_Set_File)); Gen_Uleb128 (Unsigned_32 (Cur_File)); Last_File := Cur_File; elsif Cur_File = 0 then @@ -140,17 +140,17 @@ package body Ortho_Code.Dwarf is 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_8 (Byte (DW_LNS_Advance_Line)); Gen_Sleb128 (Int32 (D_Ln - Line_Base)); D_Ln := Line_Base; end if; if D_Pc >= Line_Max_Addr then -- Emit an advance addr. - Gen_B8 (Byte (DW_LNS_Advance_Pc)); + Gen_8 (Byte (DW_LNS_Advance_Pc)); Gen_Uleb128 (Unsigned_32 (D_Pc)); D_Pc := 0; end if; - Gen_B8 (Line_Opcode_Base + Gen_8 (Line_Opcode_Base + Byte (D_Pc) * Line_Range + Byte (D_Ln - Line_Base)); @@ -240,7 +240,7 @@ package body Ortho_Code.Dwarf is procedure Gen_Abbrev_Header (Tag : Unsigned_32; Child : Byte) is begin Gen_Uleb128 (Tag); - Gen_B8 (Child); + Gen_8 (Child); end Gen_Abbrev_Header; procedure Gen_Abbrev_Tuple (Attr : Unsigned_32; Form : Unsigned_32) is @@ -262,10 +262,10 @@ package body Ortho_Code.Dwarf is 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); + Gen_8 (0); -- extended opcode + Gen_8 (1 + Pc_Type_Sizeof); -- length + Gen_8 (Byte (DW_LNE_Set_Address)); + Gen_Ua_Addr (Orig_Sym, 0); Line_Last := 1; @@ -304,14 +304,14 @@ package body Ortho_Code.Dwarf is Gen_32 (7); -- Length: to be patched. Gen_16 (2); -- version - Gen_Ua_32 (Abbrev_Sym, 0); -- Abbrev offset - Gen_B8 (4); -- Ptr size. + Gen_Ua_32 (Abbrev_Sym); -- Abbrev offset + Gen_8 (Pc_Type_Sizeof); -- 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_Ua_32 (Line_Sym); + Gen_Ua_Addr (Orig_Sym, 0); + Gen_Ua_Addr (End_Sym, 0); Gen_String_Nul ("T.Gingold ortho_mcode (2004)"); Gen_String_Nul (GNAT.Directory_Operations.Get_Current_Dir); end Init; @@ -359,28 +359,28 @@ package body Ortho_Code.Dwarf is -- header_length (to be patched). Gen_32 (5 + 12 + 1); -- minimum_instruction_length. - Gen_B8 (Min_Insn_Len); + Gen_8 (Min_Insn_Len); -- default_is_stmt - Gen_B8 (1); + Gen_8 (1); -- line base - Gen_B8 (Line_Base); + Gen_8 (Line_Base); -- line range - Gen_B8 (Line_Range); + Gen_8 (Line_Range); -- opcode base - Gen_B8 (Line_Opcode_Base); + Gen_8 (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 + Gen_8 (0); -- copy + Gen_8 (1); -- advance pc + Gen_8 (1); -- advance line + Gen_8 (1); -- set file + Gen_8 (1); -- set column + Gen_8 (0); -- negate stmt + Gen_8 (0); -- set basic block + Gen_8 (0); -- const add pc + Gen_8 (1); -- fixed advance pc + Gen_8 (0); -- set prologue end + Gen_8 (0); -- set epilogue begin + Gen_8 (1); -- set isa --if Line_Opcode_Base /= 13 then -- raise Program_Error; --end if; @@ -394,7 +394,7 @@ package body Ortho_Code.Dwarf is Gen_String_Nul (D.Name.all); D := D.Next; end loop; - Gen_B8 (0); -- last entry. + Gen_8 (0); -- last entry. end; -- file_names. @@ -405,11 +405,11 @@ package body Ortho_Code.Dwarf is while F /= null loop Gen_String_Nul (F.Name.all); Gen_Uleb128 (Unsigned_32 (F.Dir)); - Gen_B8 (0); -- time - Gen_B8 (0); -- length + Gen_8 (0); -- time + Gen_8 (0); -- length F := F.Next; end loop; - Gen_B8 (0); -- last entry. + Gen_8 (0); -- last entry. end; -- Set prolog length @@ -418,9 +418,9 @@ package body Ortho_Code.Dwarf is 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)); + Gen_8 (0); -- extended opcode + Gen_8 (1); -- length: 1 + Gen_8 (Byte (DW_LNE_End_Sequence)); -- Set total length. Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4)); @@ -437,13 +437,13 @@ package body Ortho_Code.Dwarf is Set_Section_Info (Aranges_Sect, null, 0, 0); Set_Current_Section (Aranges_Sect); - Gen_32 (28); -- Length. + Gen_32 (24 + Pc_Type_Sizeof); -- 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_Ua_32 (Info_Sym); -- info offset + Gen_8 (Pc_Type_Sizeof); -- Ptr size. + Gen_8 (0); -- seg desc size. Gen_32 (0); -- pad - Gen_Ua_32 (Orig_Sym, 0); -- text offset + Gen_Ua_Addr (Orig_Sym, 0); -- text offset Gen_32 (Unsigned_32 (Length)); Gen_32 (0); -- End Gen_32 (0); @@ -588,15 +588,15 @@ package body Ortho_Code.Dwarf is case Get_Type_Kind (Atype) is when OT_Signed => - Gen_B8 (DW_ATE_Signed); + Gen_8 (DW_ATE_Signed); when OT_Unsigned => - Gen_B8 (DW_ATE_Unsigned); + Gen_8 (DW_ATE_Unsigned); when OT_Float => - Gen_B8 (DW_ATE_Float); + Gen_8 (DW_ATE_Float); when others => raise Program_Error; end case; - Gen_B8 (Byte (Get_Type_Size (Atype))); + Gen_8 (Byte (Get_Type_Size (Atype))); end Emit_Base_Type; procedure Emit_Access_Type (Atype : O_Tnode; Decl : O_Dnode) @@ -638,7 +638,7 @@ package body Ortho_Code.Dwarf is Gen_Info_Header (Abbrev_Uncomplete_Pointer_Name); Emit_Decl_Ident (Decl); end if; - Gen_B8 (Byte (Get_Type_Size (Atype))); + Gen_8 (Byte (Get_Type_Size (Atype))); else if Decl = O_Dnode_Null then if Abbrev_Pointer = 0 then @@ -657,7 +657,7 @@ package body Ortho_Code.Dwarf is Gen_Info_Header (Abbrev_Pointer_Name); Emit_Decl_Ident (Decl); end if; - Gen_B8 (Byte (Get_Type_Size (Atype))); + Gen_8 (Byte (Get_Type_Size (Atype))); -- Break possible loops: generate the access entry... D_Pc := Get_Current_Pc; Gen_32 (0); @@ -758,7 +758,7 @@ package body Ortho_Code.Dwarf is Gen_Info_Header (Abbrev_Subrange); Emit_Type_Ref (Get_Type_Ucarray_Index (Base)); - Gen_B8 (0); + Gen_8 (0); Gen_Uleb128 (Unsigned_32 (Get_Type_Subarray_Length (Atype))); Gen_Uleb128 (0); @@ -797,10 +797,10 @@ package body Ortho_Code.Dwarf is -- Location. Loc_Pc := Get_Current_Pc; - Gen_B8 (3); - Gen_B8 (DW_OP_Plus_Uconst); + Gen_8 (3); + Gen_8 (DW_OP_Plus_Uconst); Gen_Uleb128 (Unsigned_32 (Get_Field_Offset (F))); - Patch_B8 (Loc_Pc, Unsigned_8 (Get_Current_Pc - (Loc_Pc + 1))); + Patch_8 (Loc_Pc, Unsigned_8 (Get_Current_Pc - (Loc_Pc + 1))); F := Get_Field_Chain (F); Nbr := Nbr - 1; @@ -926,7 +926,7 @@ package body Ortho_Code.Dwarf is Sibling_Pc := Gen_Info_Sibling; Emit_Decl_Ident_If_Set (Decl); - Gen_B8 (Byte (Get_Type_Size (Atype))); + Gen_8 (Byte (Get_Type_Size (Atype))); case Get_Type_Kind (Atype) is when OT_Enum => Nbr := Get_Type_Enum_Nbr_Lits (Atype); @@ -1048,19 +1048,19 @@ package body Ortho_Code.Dwarf is Pc : Pc_Type; begin Pc := Get_Current_Pc; - Gen_B8 (2); - Gen_B8 (DW_OP_Fbreg); + Gen_8 (2); + Gen_8 (DW_OP_Fbreg); Gen_Sleb128 (Get_Decl_Info (Decl)); - Patch_B8 (Pc, Unsigned_8 (Get_Current_Pc - (Pc + 1))); + Patch_8 (Pc, Unsigned_8 (Get_Current_Pc - (Pc + 1))); end Emit_Local_Location; procedure Emit_Global_Location (Decl : O_Dnode) is use Ortho_Code.Binary; begin - Gen_B8 (5); - Gen_B8 (DW_OP_Addr); - Gen_Ua_32 (Get_Decl_Symbol (Decl), 0); + Gen_8 (1 + Pc_Type_Sizeof); + Gen_8 (DW_OP_Addr); + Gen_Ua_Addr (Get_Decl_Symbol (Decl), 0); end Emit_Global_Location; procedure Emit_Variable (Decl : O_Dnode) @@ -1155,8 +1155,8 @@ package body Ortho_Code.Dwarf is 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))); + Gen_Ua_Addr (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl))); + Gen_Ua_Addr (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl))); end if; -- Emit decls for children. @@ -1240,8 +1240,8 @@ package body Ortho_Code.Dwarf is -- Low, High. 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))); + Gen_Ua_Addr (Subprg_Sym, 0); + Gen_Ua_Addr (Subprg_Sym, Integer_32 (Get_Body_Info (Bod))); if Flag_Debug >= Debug_Dwarf then -- Type. @@ -1253,8 +1253,15 @@ package body Ortho_Code.Dwarf is Sibling_Pc := Gen_Info_Sibling; -- Frame base. - Gen_B8 (1); - Gen_B8 (DW_OP_Reg5); + Gen_8 (1); + case Arch is + when Arch_X86 => + Gen_8 (DW_OP_Reg5); -- ebp + when Arch_X86_64 => + Gen_8 (DW_OP_Reg6); -- rbp + when others => + raise Program_Error; + end case; end if; -- Interfaces. diff --git a/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb index 17a47f4..a529034 100644 --- a/src/ortho/mcode/ortho_code-exprs.adb +++ b/src/ortho/mcode/ortho_code-exprs.adb @@ -727,6 +727,13 @@ package body Ortho_Code.Exprs is end if; end New_Lit; + function Is_Expr_S32 (Cst : O_Enode) return Boolean is + begin + pragma Assert (Get_Expr_Kind (Cst) = OE_Const); + return Shift_Right_Arithmetic (Get_Expr_Low (Cst), 32) + = Get_Expr_High (Cst); + end Is_Expr_S32; + function Get_Static_Chain (Depth : O_Depth) return O_Enode is Cur_Depth : O_Depth := Cur_Subprg.Depth; diff --git a/src/ortho/mcode/ortho_code-exprs.ads b/src/ortho/mcode/ortho_code-exprs.ads index 971c57a..3193170 100644 --- a/src/ortho/mcode/ortho_code-exprs.ads +++ b/src/ortho/mcode/ortho_code-exprs.ads @@ -308,6 +308,9 @@ package Ortho_Code.Exprs is function Get_Expr_Low (Cst : O_Enode) return Uns32; function Get_Expr_High (Cst : O_Enode) return Uns32; + -- Help for OE_CONST: return True iff the value is a signed 32 bit value. + function Is_Expr_S32 (Cst : O_Enode) return Boolean; + -- 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); diff --git a/src/ortho/mcode/ortho_code-types.adb b/src/ortho/mcode/ortho_code-types.adb index 439c065..95ed20f 100644 --- a/src/ortho/mcode/ortho_code-types.adb +++ b/src/ortho/mcode/ortho_code-types.adb @@ -468,14 +468,16 @@ package body Ortho_Code.Types is function New_Access_Type (Dtype : O_Tnode) return O_Tnode is Res : O_Tnode; + Sz : constant Uns32 := Boolean'Pos (Mode_Ptr = Mode_P32) * 4 + + Boolean'Pos (Mode_Ptr = Mode_P64) * 8; begin Tnodes.Append (Tnode_Common'(Kind => OT_Access, - Mode => Mode_P32, - Align => Mode_Align (Mode_P32), + Mode => Mode_Ptr, + Align => Mode_Align (Mode_Ptr), Deferred => Dtype = O_Tnode_Null, Flag1 => False, Pad0 => (others => False), - Size => 4)); + Size => Sz)); Res := Tnodes.Last; Tnodes.Append (To_Tnode_Common (Tnode_Access'(Dtype => Dtype, Pad => 0))); diff --git a/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb index 0a44339..aa6eb19 100644 --- a/src/ortho/mcode/ortho_code-x86-abi.adb +++ b/src/ortho/mcode/ortho_code-x86-abi.adb @@ -25,28 +25,65 @@ 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 + -- First argument is at %ebp + 8 / %rbp + 16 + Subprg_Stack_Init : constant Int32 := + Boolean'Pos (Flags.M64) * 16 + + Boolean'Pos (not Flags.M64) * 8; + 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; + Abi := (Offset => Subprg_Stack_Init, Inum => 0, Fnum => 0); end Start_Subprogram; + type Regs_List is array (Natural range <>) of O_Reg; + Int_Regs : constant Regs_List := + (R_Di, R_Si, R_Dx, R_Cx, R_R8, R_R9); + Sse_Regs : constant Regs_List := + (R_Xmm0, R_Xmm1, R_Xmm2, R_Xmm3, R_Xmm4, R_Xmm5, R_Xmm6, R_Xmm7); + procedure New_Interface (Inter : O_Dnode; Abi : in out O_Abi_Subprg) is - Itype : O_Tnode; + Itype : constant O_Tnode := Get_Decl_Type (Inter); Size : Uns32; + Reg : O_Reg; begin - Itype := Get_Decl_Type (Inter); - Size := Get_Type_Size (Itype); - Size := (Size + 3) and not 3; + Reg := R_None; + + if Flags.M64 then + -- AMD64 ABI 3.2.3 Parameter passing + -- The size of each argument gets rounded up to eight bytes. + Size := 0; + case Get_Type_Mode (Itype) is + when Mode_Int | Mode_Uns | Mode_B2 | Mode_P64 => + if Abi.Inum <= Int_Regs'Last then + Reg := Int_Regs (Abi.Inum); + Abi.Inum := Abi.Inum + 1; + else + Size := 8; + end if; + when Mode_Fp => + if Abi.Fnum <= Sse_Regs'Last then + Reg := Sse_Regs (Abi.Fnum); + Abi.Fnum := Abi.Fnum + 1; + else + Size := 8; + end if; + when others => + -- Parameters are scalars. + raise Program_Error; + end case; + else + Size := Get_Type_Size (Itype); + Size := (Size + 3) and not 3; + end if; + Set_Decl_Reg (Inter, Reg); Set_Local_Offset (Inter, Abi.Offset); Abi.Offset := Abi.Offset + Int32 (Size); end New_Interface; @@ -57,10 +94,10 @@ package body Ortho_Code.X86.Abi is 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); + Set_Decl_Info + (Subprg, To_Int32 (Create_Symbol (Get_Decl_Ident (Subprg), True))); + -- Offset is 8/16 biased. + Set_Subprg_Stack (Subprg, Abi.Offset - Subprg_Stack_Init); end Finish_Subprogram; procedure Link_Stmt (Stmt : O_Enode) is @@ -281,8 +318,8 @@ package body Ortho_Code.X86.Abi is when Regs_R32 | R_Any32 | R_Any8 - | Regs_R64 - | R_Any64 + | Regs_Pair + | R_AnyPair | Regs_Cc | Regs_Fp | Regs_Xmm => @@ -301,6 +338,9 @@ package body Ortho_Code.X86.Abi is Disp_Irm_Code (Get_Expr_Left (Stmt)); Put (" + "); Disp_Irm_Code (Get_Expr_Right (Stmt)); + when OE_Addrg => + Put ("&"); + Disp_Decl_Name (Get_Addr_Object (Stmt)); when others => raise Program_Error; end case; @@ -695,14 +735,16 @@ package body Ortho_Code.X86.Abi is 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_Any32 => + return "r32 "; when R_Any64 => return "r64 "; + when R_AnyPair => + return "pair"; when R_St0 => return "st0 "; @@ -722,6 +764,23 @@ package body Ortho_Code.X86.Abi is return "sp "; when R_Bp => return "bp "; + when R_R8 => + return "r8 "; + when R_R9 => + return "r9 "; + when R_R10 => + return "r10 "; + when R_R11 => + return "r11 "; + when R_R12 => + return "r12 "; + when R_R13 => + return "r13 "; + when R_R14 => + return "r14 "; + when R_R15 => + return "r15 "; + when R_Edx_Eax => return "dxax"; when R_Ebx_Ecx => @@ -775,21 +834,22 @@ package body Ortho_Code.X86.Abi is procedure Chkstk (Sz : Integer); pragma Import (C, Chkstk, "__chkstk"); - procedure Link_Intrinsics - is + 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); - Binary_File.Memory.Set_Symbol_Address - (Ortho_Code.X86.Emits.Intrinsics_Symbol - (Ortho_Code.X86.Intrinsic_Mod_Ov_I64), - Moddi3'Address); + if not Flags.M64 then + 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); + Binary_File.Memory.Set_Symbol_Address + (Ortho_Code.X86.Emits.Intrinsics_Symbol + (Ortho_Code.X86.Intrinsic_Mod_Ov_I64), + Moddi3'Address); + end if; if X86.Flags.Flag_Alloca_Call then Binary_File.Memory.Set_Symbol_Address (Ortho_Code.X86.Emits.Chkstk_Symbol, Chkstk'Address); diff --git a/src/ortho/mcode/ortho_code-x86-abi.ads b/src/ortho/mcode/ortho_code-x86-abi.ads index e22dc04..484cf3c 100644 --- a/src/ortho/mcode/ortho_code-x86-abi.ads +++ b/src/ortho/mcode/ortho_code-x86-abi.ads @@ -16,6 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ortho_Code.Types; use Ortho_Code.Types; +with Ortho_Code.X86.Flags; package Ortho_Code.X86.Abi is type O_Abi_Subprg is private; @@ -27,12 +28,16 @@ package Ortho_Code.X86.Abi is (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_U64 | Mode_I64 => 2 + Boolean'Pos (Flags.M64), Mode_F64 => 2, -- 2 for SVR4-ABI and Darwin, 3 for Windows. - Mode_Blk | Mode_X1 | Mode_Nil | Mode_P64 => 0, + Mode_P64 => 3, + Mode_Blk | Mode_X1 | Mode_Nil => 0, Mode_B2 => 0); - Mode_Ptr : constant Mode_Type := Mode_P32; + -- A long and complex expression for: flags.M64 ? Mode_P64 : Mode_P32. + Mode_Ptr : constant Mode_Type := Mode_Type'Val + (Boolean'Pos (Flags.M64) * Mode_Type'Pos (Mode_P64) + + Boolean'Pos (not Flags.M64) * Mode_Type'Pos (Mode_P32)); Flag_Type_Completer : constant Boolean := False; Flag_Lower_Stmt : constant Boolean := True; @@ -78,7 +83,10 @@ package Ortho_Code.X86.Abi is private -- Target specific data for O_Inter_List. type O_Abi_Subprg is record - -- For x86: offset of the next argument. + -- For x86: offset of the next argument in the stack. Offset : Int32 := 0; + -- For x86-64: register num. + Inum : Natural := 0; + Fnum : Natural := 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 index c4cfee9..ed17d0b 100644 --- a/src/ortho/mcode/ortho_code-x86-emits.adb +++ b/src/ortho/mcode/ortho_code-x86-emits.adb @@ -30,7 +30,23 @@ 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 Insn_Size is (Sz_8, Sz_16, Sz_32, Sz_32l, Sz_32h, Sz_64); + + -- Sz_64 if M64 or Sz_32 + Sz_Ptr : constant Insn_Size := Insn_Size'Val + (Boolean'Pos (Flags.M64) * Insn_Size'Pos (Sz_64) + + Boolean'Pos (not Flags.M64) * Insn_Size'Pos (Sz_32)); + + -- For FP, size doesn't matter in modrm and SIB. But don't emit the REX.W + -- prefix, that's useless. + Sz_Fp : constant Insn_Size := Sz_32; + + type Int_Mode_To_Size_Array is array (Mode_U8 .. Mode_I64) of Insn_Size; + Int_Mode_To_Size : constant Int_Mode_To_Size_Array := + (Mode_U8 | Mode_I8 => Sz_8, + Mode_U16 | Mode_I16 => Sz_16, + Mode_U32 | Mode_I32 => Sz_32, + Mode_U64 | Mode_I64 => Sz_64); -- Well known sections. Sect_Text : Binary_File.Section_Acc; @@ -46,6 +62,11 @@ package body Ortho_Code.X86.Emits is -- x86 opcodes. Opc_Data16 : constant := 16#66#; +-- Opc_Rex : constant := 16#40#; + Opc_Rex_W : constant := 16#48#; + Opc_Rex_R : constant := 16#44#; + Opc_Rex_X : constant := 16#42#; + Opc_Rex_B : constant := 16#41#; Opc_Into : constant := 16#ce#; Opc_Cdq : constant := 16#99#; Opc_Int : constant := 16#cd#; @@ -56,6 +77,7 @@ package body Ortho_Code.X86.Emits is Opc_Leal_Reg_Rm : constant := 16#8d#; Opc_Movb_Imm_Reg : constant := 16#b0#; Opc_Movl_Imm_Reg : constant := 16#b8#; + Opc_Movsxd_Reg_Rm : constant := 16#63#; Opc_Imul_Reg_Rm_Imm32 : constant := 16#69#; Opc_Imul_Reg_Rm_Imm8 : constant := 16#6b#; Opc_Mov_Rm_Imm : constant := 16#c6#; -- Eb,Ib or Ev,Iz (grp11, opc2=0) @@ -104,6 +126,10 @@ package body Ortho_Code.X86.Emits is Opc_Jmp_Short : constant := 16#eb#; Opc_Ret : constant := 16#c3#; Opc_Leave : constant := 16#c9#; + Opc_Movsd_Xmm_M64 : constant := 16#10#; -- Load xmm <- M64 + Opc_Movsd_M64_Xmm : constant := 16#11#; -- Store M64 <- xmm + Opc_Cvtsi2sd_Xmm_Rm : constant := 16#2a#; -- Xmm <- cvt (rm) + Opc_Cvtsd2si_Reg_Xm : constant := 16#2d#; -- Reg <- cvt (xmm/m64) procedure Error_Emit (Msg : String; Insn : O_Enode) is @@ -120,6 +146,31 @@ package body Ortho_Code.X86.Emits is raise Program_Error; end Error_Emit; + procedure Gen_Rex (B : Byte) is + begin + if Flags.M64 then + Gen_8 (B); + end if; + end Gen_Rex; + + procedure Gen_Rex_B (R : O_Reg; Sz : Insn_Size) + is + B : Byte; + begin + if Flags.M64 then + B := 0; + if R in Regs_R8_R15 or R in Regs_Xmm8_Xmm15 then + B := B or Opc_Rex_B; + end if; + if Sz = Sz_64 then + B := B or Opc_Rex_W; + end if; + if B /= 0 then + Gen_8 (B); + end if; + end if; + end Gen_Rex_B; + -- For many opcodes, the size of the operand is coded in bit 0, and the -- prefix data16 can be used for 16-bit operation. -- Deal with size. @@ -127,13 +178,15 @@ package body Ortho_Code.X86.Emits is begin case Sz is when Sz_8 => - Gen_B8 (B); + Gen_8 (B); when Sz_16 => - Gen_B8 (Opc_Data16); - Gen_B8 (B + 1); - when Sz_32l - | Sz_32h => - Gen_B8 (B + 1); + Gen_8 (Opc_Data16); + Gen_8 (B + 1); + when Sz_32 + | Sz_32l + | Sz_32h + | Sz_64 => + Gen_8 (B + 1); end case; end Gen_Insn_Sz; @@ -141,13 +194,15 @@ package body Ortho_Code.X86.Emits is begin case Sz is when Sz_8 => - Gen_B8 (B); + Gen_8 (B); when Sz_16 => - Gen_B8 (Opc_Data16); - Gen_B8 (B + 3); - when Sz_32l - | Sz_32h => - Gen_B8 (B + 3); + Gen_8 (Opc_Data16); + Gen_8 (B + 3); + when Sz_32 + | Sz_32l + | Sz_32h + | Sz_64 => + Gen_8 (B + 3); end case; end Gen_Insn_Sz_S8; @@ -156,10 +211,13 @@ package body Ortho_Code.X86.Emits is case Sz is when Sz_8 | Sz_16 + | Sz_32 | Sz_32l => return Get_Expr_Low (C); when Sz_32h => return Get_Expr_High (C); + when Sz_64 => + return Get_Expr_Low (C); end case; end Get_Const_Val; @@ -173,7 +231,7 @@ package body Ortho_Code.X86.Emits is procedure Gen_Imm8 (N : O_Enode; Sz : Insn_Size) is begin - Gen_B8 (Byte (Get_Const_Val (N, Sz))); + Gen_8 (Byte (Get_Const_Val (N, Sz))); end Gen_Imm8; -- procedure Gen_Imm32 (N : O_Enode; Sz : Insn_Size) @@ -182,7 +240,7 @@ package body Ortho_Code.X86.Emits is -- begin -- case Get_Expr_Kind (N) is -- when OE_Const => --- Gen_Le32 (Unsigned_32 (Get_Const_Val (N, Sz))); +-- Gen_32 (Unsigned_32 (Get_Const_Val (N, Sz))); -- when OE_Addrg => -- Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (N)), 0); -- when others => @@ -191,59 +249,148 @@ package body Ortho_Code.X86.Emits is -- end Gen_Imm32; -- Generate an immediat constant. + procedure Gen_Imm_Addr (N : O_Enode) + is + Sym : Symbol; + P : O_Enode; + L, R : O_Enode; + S, C : O_Enode; + Off : Int32; + begin + Off := 0; + P := N; + while Get_Expr_Kind (P) = OE_Add 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; + pragma Assert (Get_Expr_Mode (C) = Mode_U32); + Off := Off + To_Int32 (Get_Expr_Low (C)); + P := S; + end loop; + pragma Assert (Get_Expr_Kind (P) = OE_Addrg); + Sym := Get_Decl_Symbol (Get_Addr_Object (P)); + Gen_Abs (Sym, Integer_32 (Off)); + end Gen_Imm_Addr; + + -- Generate an immediat constant. 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#)); + Gen_8 (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))); + Gen_16 (Unsigned_32 (Get_Expr_Low (N) and 16#FF_FF#)); + when Sz_32 + | Sz_32l => + Gen_32 (Unsigned_32 (Get_Expr_Low (N))); when Sz_32h => - Gen_Le32 (Unsigned_32 (Get_Expr_High (N))); + Gen_32 (Unsigned_32 (Get_Expr_High (N))); + when Sz_64 => + -- Immediates are sign extended. + pragma Assert (Is_Expr_S32 (N)); + Gen_32 (Unsigned_32 (Get_Expr_Low (N))); end case; when OE_Add | OE_Addrg => -- Only for 32-bit immediat. - pragma Assert (Sz = Sz_32l); - declare - P : O_Enode; - L, R : O_Enode; - S, C : O_Enode; - Off : Int32; - begin - Off := 0; - P := N; - while Get_Expr_Kind (P) = OE_Add 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; - pragma Assert (Get_Expr_Mode (C) = Mode_U32); - Off := Off + To_Int32 (Get_Expr_Low (C)); - P := S; - end loop; - pragma Assert (Get_Expr_Kind (P) = OE_Addrg); - Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (P)), - Integer_32 (Off)); - end; + pragma Assert (Sz = Sz_32); + Gen_Imm_Addr (N); when others => raise Program_Error; end case; end Gen_Imm; + function To_Reg32 (R : O_Reg) return Byte is + begin + pragma Assert (R in Regs_R32); + return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); + end To_Reg32; + pragma Inline (To_Reg32); + + function To_Reg64 (R : O_Reg) return Byte is + begin + pragma Assert (R in Regs_R64); + return Byte (O_Reg'Pos (R) - O_Reg'Pos (R_Ax)) and 7; + end To_Reg64; + pragma Inline (To_Reg64); + + 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 => + pragma Assert ((not Flags.M64 and R in Regs_R8) + or (Flags.M64 and R in Regs_R64)); + return To_Reg64 (R); + when Sz_16 => + pragma Assert (R in Regs_R32); + return To_Reg64 (R); + when Sz_32 => + pragma Assert ((not Flags.M64 and R in Regs_R32) + or (Flags.M64 and R in Regs_R64)); + return To_Reg64 (R); + when Sz_32l => + pragma Assert (not Flags.M64); + case R is + 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 => + pragma Assert (not Flags.M64); + 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; + when Sz_64 => + pragma Assert (R in Regs_R64); + return Byte (O_Reg'Pos (R) - O_Reg'Pos (R_Ax)) and 7; + 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); + + function To_Reg (R : O_Reg; Sz : Insn_Size) return Byte is + begin + if R in Regs_Xmm then + return To_Reg_Xmm (R); + else + return To_Reg32 (R, Sz); + end if; + end To_Reg; + -- SIB + disp values. SIB_Scale : Byte; SIB_Index : O_Reg; @@ -251,18 +398,52 @@ package body Ortho_Code.X86.Emits is Rm_Offset : Int32; Rm_Sym : Symbol; + -- If not R_Nil, the reg/opc field (bit 3-5) of the ModR/M byte is a + -- register. + Rm_Opc_Reg : O_Reg; + Rm_Opc_Sz : Insn_Size; + -- If not R_Nil, encode mod=11 (no memory access). All above variables -- must be 0/R_Nil. Rm_Reg : O_Reg; Rm_Sz : Insn_Size; + procedure Gen_Rex_Mod_Rm + is + B : Byte; + begin + if Flags.M64 then + B := 0; + if Rm_Sz = Sz_64 then + B := B or Opc_Rex_W; + end if; + if Rm_Opc_Reg in Regs_R8_R15 + or Rm_Opc_Reg in Regs_Xmm8_Xmm15 + then + B := B or Opc_Rex_R; + end if; + if Rm_Reg in Regs_R8_R15 + or Rm_Reg in Regs_Xmm8_Xmm15 + or Rm_Base in Regs_R8_R15 + then + B := B or Opc_Rex_B; + end if; + if SIB_Index in Regs_R8_R15 then + B := B or Opc_Rex_X; + end if; + if B /= 0 then + Gen_8 (B); + end if; + end if; + end Gen_Rex_Mod_Rm; + procedure Fill_Sib (N : O_Enode) is use Ortho_Code.Decls; Reg : constant O_Reg := Get_Expr_Reg (N); begin -- A simple register. - if Reg in Regs_R32 then + if Reg in Regs_R64 then if Rm_Base = R_Nil then Rm_Base := Reg; elsif SIB_Index = R_Nil then @@ -309,77 +490,27 @@ package body Ortho_Code.X86.Emits is end case; end Fill_Sib; - function To_Reg32 (R : O_Reg) return Byte is - begin - pragma Assert (R in Regs_R32); - 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 => - pragma Assert (R in Regs_R8); - return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); - when Sz_16 => - pragma Assert (R in Regs_R32); - return O_Reg'Pos (R) - O_Reg'Pos (R_Ax); - 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); - -- Write the SIB byte. procedure Gen_Sib is Base : Byte; begin if Rm_Base = R_Nil then - Base := 2#101#; + Base := 2#101#; -- BP else - Base := To_Reg32 (Rm_Base); + pragma Assert (not (SIB_Index = R_Sp + and (Rm_Base = R_Bp or Rm_Base = R_R13))); + Base := To_Reg64 (Rm_Base); end if; - Gen_B8 (SIB_Scale * 2#1_000_000# - + To_Reg32 (SIB_Index) * 2#1_000# - + Base); + Gen_8 + (SIB_Scale * 2#1_000_000# + To_Reg64 (SIB_Index) * 2#1_000# + Base); end Gen_Sib; - procedure Init_Modrm_Reg (Reg : O_Reg; Sz : Insn_Size) is + -- ModRM is a register. + procedure Init_Modrm_Reg (Reg : O_Reg; + Sz : Insn_Size; + Opc : O_Reg := R_Nil; + Opc_Sz : Insn_Size := Sz_32) is begin Rm_Base := R_Nil; SIB_Index := R_Nil; @@ -387,12 +518,17 @@ package body Ortho_Code.X86.Emits is Rm_Sym := Null_Symbol; Rm_Offset := 0; + Rm_Opc_Reg := Opc; + Rm_Opc_Sz := Opc_Sz; + Rm_Reg := Reg; Rm_Sz := Sz; + + Gen_Rex_Mod_Rm; end Init_Modrm_Reg; -- Note: SZ is not relevant. - procedure Init_Modrm_Sym (Sym : Symbol; Sz : Insn_Size) is + procedure Init_Modrm_Sym (Sym : Symbol; Sz : Insn_Size; Opc_Reg : O_Reg) is begin Rm_Base := R_Nil; SIB_Index := R_Nil; @@ -400,11 +536,17 @@ package body Ortho_Code.X86.Emits is Rm_Sym := Sym; Rm_Offset := 0; + Rm_Opc_Reg := Opc_Reg; + Rm_Opc_Sz := Sz; + Rm_Reg := R_Nil; Rm_Sz := Sz; + + Gen_Rex_Mod_Rm; end Init_Modrm_Sym; - procedure Init_Modrm_Mem (N : O_Enode; Sz : Insn_Size) + -- ModRM is a memory reference. + procedure Init_Modrm_Mem (N : O_Enode; Sz : Insn_Size; Opc : O_Reg := R_Nil) is Reg : constant O_Reg := Get_Expr_Reg (N); begin @@ -413,6 +555,9 @@ package body Ortho_Code.X86.Emits is Rm_Reg := R_Nil; Rm_Sz := Sz; + Rm_Opc_Reg := Opc; + Rm_Opc_Sz := Sz; + if Sz = Sz_32h then Rm_Offset := 4; else @@ -429,7 +574,7 @@ package body Ortho_Code.X86.Emits is | R_I_Off | R_Sib => Fill_Sib (N); - when Regs_R32 => + when Regs_R64 => Rm_Base := Reg; when R_Spill => Rm_Base := R_Bp; @@ -437,25 +582,29 @@ package body Ortho_Code.X86.Emits is when others => Error_Emit ("init_modrm_mem: unhandled reg", N); end case; + + Gen_Rex_Mod_Rm; end Init_Modrm_Mem; - procedure Init_Rm_Expr (N : O_Enode; Sz : Insn_Size) + procedure Init_Modrm_Expr + (N : O_Enode; Sz : Insn_Size; Opc : O_Reg := R_Nil) is Reg : constant O_Reg := Get_Expr_Reg (N); begin case Reg is - when Regs_R32 - | Regs_R64 + when Regs_R64 + | Regs_Pair | Regs_Xmm => -- Destination is a register. - Init_Modrm_Reg (Reg, Sz); + Init_Modrm_Reg (Reg, Sz, Opc, Sz); when others => -- Destination is an effective address. - Init_Modrm_Mem (N, Sz); + Init_Modrm_Mem (N, Sz, Opc); end case; - end Init_Rm_Expr; + end Init_Modrm_Expr; - procedure Init_Modrm_Offset (Base : O_Reg; Off : Int32; Sz : Insn_Size) is + procedure Init_Modrm_Offset + (Base : O_Reg; Off : Int32; Sz : Insn_Size; Opc : O_Reg := R_Nil) is begin SIB_Index := R_Nil; SIB_Scale := 0; @@ -465,108 +614,135 @@ package body Ortho_Code.X86.Emits is Rm_Base := Base; + Rm_Opc_Reg := Opc; + Rm_Opc_Sz := Sz; + if Sz = Sz_32h then Rm_Offset := Off + 4; else Rm_Offset := Off; end if; + + Gen_Rex_Mod_Rm; end Init_Modrm_Offset; -- Generate an R/M (+ SIB) byte. -- R is added to the R/M byte. - procedure Gen_Mod_Rm (R : Byte) is + procedure Gen_Mod_Rm_B (R : Byte) is begin - -- Emit bytes. - if SIB_Index /= R_Nil then - pragma Assert (Rm_Reg = R_Nil); - -- SIB. + if Rm_Reg /= R_Nil then + -- Register: mod = 11, no memory access. + pragma Assert (Rm_Base = R_Nil); + pragma Assert (Rm_Sym = Null_Symbol); + pragma Assert (Rm_Offset = 0); + pragma Assert (SIB_Index = R_Nil); + Gen_8 (2#11_000_000# + R + To_Reg (Rm_Reg, Rm_Sz)); + return; + end if; + + if SIB_Index /= R_Nil or (Flags.M64 and Rm_Base = R_R12) then + -- With SIB. + if SIB_Index = R_Nil then + SIB_Index := R_Sp; + end if; if Rm_Base = R_Nil then -- No base (but index). Use the special encoding with base=BP. - Gen_B8 (2#00_000_100# + R); + Gen_8 (2#00_000_100# + R); -- mod=00, rm=SP -> disp32. 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 + if Rm_Sym = Null_Symbol then + Gen_32 (Unsigned_32 (To_Uns32 (Rm_Offset))); + else + pragma Assert (not Flags.M64); + Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); + end if; + elsif Rm_Sym = Null_Symbol and Rm_Offset = 0 + and Rm_Base /= R_Bp and Rm_Base /= R_R13 + then -- No offset (only allowed if base is not BP). - Gen_B8 (2#00_000_100# + R); + Gen_8 (2#00_000_100# + R); Gen_Sib; - elsif Rm_Sym = Null_Symbol and Rm_Offset <= 127 and Rm_Offset >= -128 - then + elsif Rm_Sym = Null_Symbol and Rm_Offset in -128 .. 127 then -- Disp8 - Gen_B8 (2#01_000_100# + R); + Gen_8 (2#01_000_100# + R); Gen_Sib; - Gen_B8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#)); + Gen_8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#)); else -- Disp32 - Gen_B8 (2#10_000_100# + R); + Gen_8 (2#10_000_100# + R); Gen_Sib; - Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); - end if; - return; - end if; - - -- No SIB. - if Rm_Reg /= R_Nil then - -- Mod is register, no memory access. - pragma Assert (Rm_Base = R_Nil); - pragma Assert (Rm_Sym = Null_Symbol); - pragma Assert (Rm_Offset = 0); - if Rm_Reg in Regs_Xmm then - Gen_B8 (2#11_000_000# + R + To_Reg_Xmm (Rm_Reg)); - else - Gen_B8 (2#11_000_000# + R + To_Reg32 (Rm_Reg, Rm_Sz)); - end if; - return; - end if; - - case Rm_Base is - when R_Sp => - -- It isn't possible to use SP as a base register without using - -- an SIB encoding. - raise Program_Error; - when R_Nil => - -- Encode for disp32 (Mod=00, R/M=101). - 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 - -- No disp: use Mod=00 (not supported if base is BP). - 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 - -- Disp8 (Mod=01) - Gen_B8 (2#01_000_000# + R + To_Reg32 (Rm_Base)); - Gen_B8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#)); + if Rm_Sym = Null_Symbol then + Gen_32 (Unsigned_32 (To_Uns32 (Rm_Offset))); else - -- Disp32 (Mod=10) - Gen_B8 (2#10_000_000# + R + To_Reg32 (Rm_Base)); + pragma Assert (not Flags.M64); Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); end if; - when others => - raise Program_Error; - end case; - end Gen_Mod_Rm; - - procedure Gen_Rm (R : Byte; N : O_Enode; Sz : Insn_Size) - is - Reg : constant O_Reg := Get_Expr_Reg (N); - begin - if Reg in Regs_R32 or Reg in Regs_R64 then - -- Destination is a register. - Gen_B8 (2#11_000_000# + R + To_Reg32 (Reg, Sz)); + end if; else - -- Destination is an effective address. - Init_Modrm_Mem (N, Sz); - Gen_Mod_Rm (R); + case Rm_Base is + when R_Sp => + -- It isn't possible to use SP as a base register without using + -- an SIB encoding. + raise Program_Error; + when R_Nil => + -- There should be no case where the offset is negative. + pragma Assert (Rm_Offset >= 0); + -- Encode for disp32 (Mod=00, R/M=101) or RIP relative + Gen_8 (2#00_000_101# + R); + if Flags.M64 then + -- RIP relative + Gen_X86_Pc32 (Rm_Sym, Unsigned_32 (Rm_Offset)); + else + -- Disp32. + Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); + end if; + when R_Ax + | R_Bx + | R_Cx + | R_Dx + | R_Bp + | R_Si + | R_Di + | R_R8 .. R_R11 + | R_R13 .. R_R15 => + if Rm_Offset = 0 and Rm_Sym = Null_Symbol + and Rm_Base /= R_Bp and Rm_Base /= R_R13 + then + -- No disp: use Mod=00 (not supported if base is BP or R13). + Gen_8 (2#00_000_000# + R + To_Reg64 (Rm_Base)); + elsif Rm_Sym = Null_Symbol + and Rm_Offset <= 127 and Rm_Offset >= -128 + then + -- Disp8 (Mod=01) + Gen_8 (2#01_000_000# + R + To_Reg64 (Rm_Base)); + Gen_8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#)); + else + -- Disp32 (Mod=10) + Gen_8 (2#10_000_000# + R + To_Reg64 (Rm_Base)); + if Rm_Sym = Null_Symbol then + Gen_32 (Unsigned_32 (To_Uns32 (Rm_Offset))); + else + pragma Assert (not Flags.M64); + Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset)); + end if; + end if; + when others => + raise Program_Error; + end case; end if; - end Gen_Rm; + end Gen_Mod_Rm_B; + + procedure Gen_Mod_Rm_Opc (R : Byte) is + begin + pragma Assert (Rm_Opc_Reg = R_Nil); + Gen_Mod_Rm_B (R); + end Gen_Mod_Rm_Opc; + + procedure Gen_Mod_Rm_Reg is + begin + pragma Assert (Rm_Opc_Reg /= R_Nil); + Gen_Mod_Rm_B (To_Reg (Rm_Opc_Reg, Rm_Opc_Sz) * 8); + end Gen_Mod_Rm_Reg; procedure Gen_Grp1_Insn (Op : Byte; Stmt : O_Enode; Sz : Insn_Size) is @@ -578,24 +754,31 @@ package body Ortho_Code.X86.Emits is 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 + if Lr = R_Ax then + -- Use compact encoding. + if Sz = Sz_64 then + Gen_8 (Opc_Rex_W); + end if; Gen_Insn_Sz (2#000_000_100# + Op, Sz); Gen_Imm (R, Sz); + elsif Is_Imm8 (R, Sz) then + Init_Modrm_Expr (L, Sz); + Gen_Insn_Sz_S8 (16#80#, Sz); + Gen_Mod_Rm_Opc (Op); + Gen_Imm8 (R, Sz); else + Init_Modrm_Expr (L, Sz); Gen_Insn_Sz (16#80#, Sz); - Gen_Rm (Op, L, Sz); + Gen_Mod_Rm_Opc (Op); Gen_Imm (R, Sz); end if; when R_Mem | R_Spill - | Regs_R32 - | Regs_R64 => + | Regs_R64 + | Regs_Pair => + Init_Modrm_Expr (R, Sz, Lr); Gen_Insn_Sz (2#00_000_010# + Op, Sz); - Gen_Rm (To_Reg32 (Lr, Sz) * 8, R, Sz); + Gen_Mod_Rm_Reg; when others => Error_Emit ("emit_op", Stmt); end case; @@ -606,7 +789,7 @@ package body Ortho_Code.X86.Emits is procedure Gen_1 (B : Byte) is begin Start_Insn; - Gen_B8 (B); + Gen_8 (B); End_Insn; end Gen_1; @@ -614,55 +797,57 @@ package body Ortho_Code.X86.Emits is procedure Gen_2 (B1, B2 : Byte) is begin Start_Insn; - Gen_B8 (B1); - Gen_B8 (B2); + Gen_8 (B1); + Gen_8 (B2); End_Insn; end Gen_2; -- Grp1 instructions have a mod/rm and an immediate value VAL. -- Mod/Rm must be initialized. - procedure Gen_Insn_Grp1 (Opc2 : Byte; Sz : Insn_Size; Val : Int32) is + procedure Gen_Insn_Grp1 (Opc2 : Byte; Val : Int32) is begin - Start_Insn; if Val in -128 .. 127 then - case Sz is + case Rm_Sz is when Sz_8 => - Gen_B8 (Opc_Grp1b_Rm_Imm8); + Gen_8 (Opc_Grp1b_Rm_Imm8); when Sz_16 => - Gen_B8 (Opc_Data16); - Gen_B8 (Opc_Grp1v_Rm_Imm8); - when Sz_32l - | Sz_32h => - Gen_B8 (Opc_Grp1v_Rm_Imm8); + Gen_8 (Opc_Data16); + Gen_8 (Opc_Grp1v_Rm_Imm8); + when Sz_32 + | Sz_32l + | Sz_32h + | Sz_64 => + Gen_8 (Opc_Grp1v_Rm_Imm8); end case; - Gen_Mod_Rm (Opc2); - Gen_B8 (Byte (To_Uns32 (Val) and 16#Ff#)); + Gen_Mod_Rm_Opc (Opc2); + Gen_8 (Byte (To_Uns32 (Val) and 16#Ff#)); else - case Sz is + case Rm_Sz is when Sz_8 => pragma Assert (False); null; when Sz_16 => - Gen_B8 (Opc_Data16); - Gen_B8 (Opc_Grp1v_Rm_Imm32); - when Sz_32l - | Sz_32h => - Gen_B8 (Opc_Grp1v_Rm_Imm32); + Gen_8 (Opc_Data16); + Gen_8 (Opc_Grp1v_Rm_Imm32); + when Sz_32 + | Sz_32l + | Sz_32h + | Sz_64 => + Gen_8 (Opc_Grp1v_Rm_Imm32); end case; - Gen_Mod_Rm (Opc2); - Gen_Le32 (Unsigned_32 (To_Uns32 (Val))); + Gen_Mod_Rm_Opc (Opc2); + Gen_32 (Unsigned_32 (To_Uns32 (Val))); end if; - End_Insn; end Gen_Insn_Grp1; - procedure Gen_Into is - begin - Gen_1 (Opc_Into); - end Gen_Into; - - procedure Gen_Cdq is + procedure Gen_Cdq (Sz : Insn_Size) is begin - Gen_1 (Opc_Cdq); + Start_Insn; + if Sz = Sz_64 then + Gen_8 (Opc_Rex_W); + end if; + Gen_8 (Opc_Cdq); + End_Insn; end Gen_Cdq; procedure Gen_Clear_Edx is @@ -675,8 +860,9 @@ package body Ortho_Code.X86.Emits is begin Start_Insn; -- Unary Group 3 (test, not, neg...) + Init_Modrm_Expr (Val, Sz); Gen_Insn_Sz (Opc_Grp3_Width, Sz); - Gen_Rm (Op, Val, Sz); + Gen_Mod_Rm_Opc (Op); End_Insn; end Gen_Grp3_Insn; @@ -695,15 +881,37 @@ package body Ortho_Code.X86.Emits is -- Mov immediate. case Sz is when Sz_8 => - Gen_B8 (Opc_Movb_Imm_Reg + To_Reg32 (Tr, Sz)); + Gen_Rex_B (Tr, Sz); + Gen_8 (Opc_Movb_Imm_Reg + To_Reg32 (Tr, Sz)); + Gen_Imm (Stmt, Sz); when Sz_16 => - Gen_B8 (Opc_Data16); - Gen_B8 (Opc_Movl_Imm_Reg + To_Reg32 (Tr, Sz)); - when Sz_32l + Gen_8 (Opc_Data16); + Gen_8 (Opc_Movl_Imm_Reg + To_Reg32 (Tr, Sz)); + Gen_Imm (Stmt, Sz); + when Sz_32 + | Sz_32l | Sz_32h => - Gen_B8 (Opc_Movl_Imm_Reg + To_Reg32 (Tr, Sz)); + Gen_Rex_B (Tr, Sz); + Gen_8 (Opc_Movl_Imm_Reg + To_Reg32 (Tr, Sz)); + Gen_Imm (Stmt, Sz); + when Sz_64 => + if Get_Expr_Kind (Stmt) = OE_Const then + if Get_Expr_High (Stmt) = 0 then + Gen_Rex_B (Tr, Sz_32); + Gen_8 (Opc_Movl_Imm_Reg + To_Reg32 (Tr, Sz)); + Gen_32 (Unsigned_32 (Get_Expr_Low (Stmt))); + else + Gen_Rex_B (Tr, Sz_64); + Gen_8 (Opc_Movl_Imm_Reg + To_Reg32 (Tr, Sz)); + Gen_32 (Unsigned_32 (Get_Expr_Low (Stmt))); + Gen_32 (Unsigned_32 (Get_Expr_High (Stmt))); + end if; + else + Gen_Rex_B (Tr, Sz_64); + Gen_8 (Opc_Movl_Imm_Reg + To_Reg32 (Tr, Sz)); + Gen_Imm_Addr (Stmt); + end if; end case; - Gen_Imm (Stmt, Sz); End_Insn; end Emit_Load_Imm; @@ -737,7 +945,7 @@ package body Ortho_Code.X86.Emits is Sym : Symbol; begin Sym := Gen_Constant_Start (2); - Gen_Le32 (Val); + Gen_32 (Val); Set_Current_Section (Sect_Text); return Sym; end Gen_Constant_32; @@ -747,8 +955,8 @@ package body Ortho_Code.X86.Emits is Sym : Symbol; begin Sym := Gen_Constant_Start (3); - Gen_Le32 (Lo); - Gen_Le32 (Hi); + Gen_32 (Lo); + Gen_32 (Hi); Set_Current_Section (Sect_Text); return Sym; end Gen_Constant_64; @@ -758,10 +966,10 @@ package body Ortho_Code.X86.Emits is Sym : Symbol; begin Sym := Gen_Constant_Start (4); - Gen_Le32 (Lo); - Gen_Le32 (Hi); - Gen_Le32 (Lo); - Gen_Le32 (Hi); + Gen_32 (Lo); + Gen_32 (Hi); + Gen_32 (Lo); + Gen_32 (Hi); Set_Current_Section (Sect_Text); return Sym; end Gen_Constant_128; @@ -808,17 +1016,20 @@ package body Ortho_Code.X86.Emits is end case; end Get_Xmm_Mask_Constant; - procedure Gen_SSE_Rep_Opc (Mode : Mode_Fp; Opc : Byte) is + procedure Gen_SSE_Prefix (Mode : Mode_Fp) is begin case Mode is when Mode_F32 => - Gen_B8 (16#f3#); + Gen_8 (16#f3#); when Mode_F64 => - Gen_B8 (16#f2#); + Gen_8 (16#f2#); end case; - Gen_B8 (16#0f#); - Gen_B8 (Opc); - end Gen_SSE_Rep_Opc; + end Gen_SSE_Prefix; + + procedure Gen_SSE_Opc (Op : Byte) is + begin + Gen_8 (16#0f#, Op); + end Gen_SSE_Opc; procedure Gen_SSE_D16_Opc (Mode : Mode_Fp; Opc : Byte) is begin @@ -826,10 +1037,10 @@ package body Ortho_Code.X86.Emits is when Mode_F32 => null; when Mode_F64 => - Gen_B8 (Opc_Data16); + Gen_8 (Opc_Data16); end case; - Gen_B8 (16#0f#); - Gen_B8 (Opc); + Gen_8 (16#0f#); + Gen_8 (Opc); end Gen_SSE_D16_Opc; procedure Emit_Load_Fp (Stmt : O_Enode; Mode : Mode_Fp) @@ -850,46 +1061,44 @@ package body Ortho_Code.X86.Emits is case R is when R_St0 => Start_Insn; - Gen_B8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); - Gen_B8 (2#00_000_101#); + Gen_8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); + Gen_8 (2#00_000_101#); Gen_X86_32 (Sym, 0); End_Insn; when Regs_Xmm => Start_Insn; - Gen_SSE_Rep_Opc (Mode, 16#10#); - Gen_B8 (2#00_000_101# + To_Reg_Xmm (R) * 2#1_000#); - Gen_X86_32 (Sym, 0); + Gen_SSE_Prefix (Mode); + Gen_SSE_Opc (Opc_Movsd_Xmm_M64); + Gen_8 (2#00_000_101# + To_Reg_Xmm (R) * 2#1_000#); + if Flags.M64 then + -- RIP relative + Gen_X86_Pc32 (Sym, 0); + else + -- Disp32. + Gen_X86_32 (Sym, 0); + end if; End_Insn; when others => raise Program_Error; end case; end Emit_Load_Fp; - function Xmm_To_Modrm_Reg (R : O_Reg) return Byte is - begin - return To_Reg_Xmm (R) * 8; - end Xmm_To_Modrm_Reg; - - procedure Gen_Xmm_Modrm (Mode : Mode_Fp; Opc : Byte; Dest : O_Reg) is - begin - Start_Insn; - Gen_SSE_Rep_Opc (Mode, Opc); - Gen_Mod_Rm (Xmm_To_Modrm_Reg (Dest)); - End_Insn; - end Gen_Xmm_Modrm; - procedure Emit_Load_Fp_Mem (Stmt : O_Enode; Mode : Mode_Fp) is Dest : constant O_Reg := Get_Expr_Reg (Stmt); begin - Init_Modrm_Mem (Get_Expr_Operand (Stmt), Sz_32l); if Dest in Regs_Xmm then - Gen_Xmm_Modrm (Mode, 16#10#, Dest); + Start_Insn; + Gen_SSE_Prefix (Mode); + Init_Modrm_Mem (Get_Expr_Operand (Stmt), Sz_Fp, Dest); + Gen_SSE_Opc (Opc_Movsd_Xmm_M64); + Gen_Mod_Rm_Reg; + End_Insn; else Start_Insn; - Gen_B8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); - Init_Modrm_Mem (Get_Expr_Operand (Stmt), Sz_32l); - Gen_Mod_Rm (2#000_000#); + Init_Modrm_Mem (Get_Expr_Operand (Stmt), Sz_Fp); + Gen_8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); + Gen_Mod_Rm_Opc (2#000_000#); End_Insn; end if; end Emit_Load_Fp_Mem; @@ -900,24 +1109,25 @@ package body Ortho_Code.X86.Emits is Val : constant O_Enode := Get_Expr_Operand (Stmt); begin case Tr is - when Regs_R32 - | Regs_R64 => + when Regs_R64 + | Regs_Pair => -- mov REG, OP - Init_Modrm_Mem (Val, Sz); Start_Insn; + Init_Modrm_Mem (Val, Sz, Tr); Gen_Insn_Sz (Opc_Mov_Reg_Rm, Sz); - Gen_Mod_Rm (To_Reg32 (Tr, Sz) * 8); + Gen_Mod_Rm_Reg; End_Insn; when R_Eq => -- Cmp OP, 1 + Start_Insn; Init_Modrm_Mem (Val, Sz); - Gen_Insn_Grp1 (Opc2_Grp1_Cmp, Sz, 1); + Gen_Insn_Grp1 (Opc2_Grp1_Cmp, 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 : constant O_Enode := Get_Assign_Target (Stmt); @@ -929,29 +1139,31 @@ package body Ortho_Code.X86.Emits is Start_Insn; case Rr is when R_Imm => - if False and (Tr in Regs_R32 or Tr in Regs_R64) then + if False and (Tr in Regs_R64 or Tr in Regs_Pair) 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 => + Gen_8 (16#66#); + when Sz_32 + | Sz_32l + | Sz_32h + | Sz_64 => null; end case; - Gen_B8 (B + To_Reg32 (Tr, Sz)); + Gen_8 (B + To_Reg32 (Tr, Sz)); else Init_Modrm_Mem (T, Sz); Gen_Insn_Sz (Opc_Mov_Rm_Imm, Sz); - Gen_Mod_Rm (16#00#); + Gen_Mod_Rm_Opc (16#00#); end if; Gen_Imm (R, Sz); - when Regs_R32 - | Regs_R64 => + when Regs_R64 + | Regs_Pair => + Init_Modrm_Mem (T, Sz, Rr); Gen_Insn_Sz (Opc_Mov_Rm_Reg, Sz); - Init_Modrm_Mem (T, Sz); - Gen_Mod_Rm (To_Reg32 (Rr, Sz) * 8); + Gen_Mod_Rm_Reg; when others => Error_Emit ("emit_store", Stmt); end case; @@ -962,61 +1174,79 @@ package body Ortho_Code.X86.Emits is begin -- fstp Start_Insn; - Gen_B8 (2#11011_00_1# + Mode_Fp_To_Mf (Mode)); - Init_Modrm_Mem (Get_Assign_Target (Stmt), Sz_32l); - Gen_Mod_Rm (2#011_000#); + Init_Modrm_Mem (Get_Assign_Target (Stmt), Sz_Ptr); + Gen_8 (2#11011_00_1# + Mode_Fp_To_Mf (Mode)); + Gen_Mod_Rm_Opc (2#011_000#); End_Insn; end Emit_Store_Fp; procedure Emit_Store_Xmm (Stmt : O_Enode; Mode : Mode_Fp) is begin -- movsd - Init_Modrm_Mem (Get_Assign_Target (Stmt), Sz_32l); Start_Insn; - Gen_SSE_Rep_Opc (Mode, 16#11#); - Gen_Mod_Rm (To_Reg_Xmm (Get_Expr_Reg (Get_Expr_Operand (Stmt))) * 8); + Gen_SSE_Prefix (Mode); + Init_Modrm_Mem (Get_Assign_Target (Stmt), Sz_Fp, + Get_Expr_Reg (Get_Expr_Operand (Stmt))); + Gen_SSE_Opc (Opc_Movsd_M64_Xmm); + Gen_Mod_Rm_Reg; End_Insn; end Emit_Store_Xmm; - procedure Emit_Push_32 (Val : O_Enode; Sz : Insn_Size) + procedure Gen_Push_Pop_Reg (Opc : Byte; Reg : O_Reg; Sz : Insn_Size) is + begin + Start_Insn; + if Reg in Regs_R8_R15 then + Gen_8 (Opc_Rex_B); + end if; + Gen_8 (Opc + To_Reg32 (Reg, Sz)); + End_Insn; + end Gen_Push_Pop_Reg; + + procedure Emit_Push (Val : O_Enode; Sz : Insn_Size) is R : constant O_Reg := Get_Expr_Reg (Val); begin - Start_Insn; case R is when R_Imm => + Start_Insn; if Is_Imm8 (Val, Sz) then - Gen_B8 (Opc_Push_Imm8); + Gen_8 (Opc_Push_Imm8); Gen_Imm8 (Val, Sz); else - Gen_B8 (Opc_Push_Imm); + Gen_8 (Opc_Push_Imm); Gen_Imm (Val, Sz); end if; - when Regs_R32 - | Regs_R64 => - Gen_B8 (Opc_Push_Reg + To_Reg32 (R, Sz)); + End_Insn; + when Regs_R64 + | Regs_Pair => + Gen_Push_Pop_Reg (Opc_Push_Reg, R, Sz); when others => - Gen_B8 (Opc_Grp5); - Gen_Rm (Opc2_Grp5_Push_Rm, Val, Sz); + Start_Insn; + Init_Modrm_Expr (Val, Sz); + Gen_8 (Opc_Grp5); + Gen_Mod_Rm_Opc (Opc2_Grp5_Push_Rm); + End_Insn; end case; - End_Insn; - end Emit_Push_32; + end Emit_Push; procedure Emit_Subl_Sp_Imm (Len : Byte) is begin Start_Insn; - Gen_B8 (Opc_Grp1v_Rm_Imm8); - Gen_B8 (Opc2_Grp1_Sub + 2#11_000_100#); - Gen_B8 (Len); + Gen_Rex (Opc_Rex_W); + Gen_8 (Opc_Grp1v_Rm_Imm8); + Gen_8 (Opc2_Grp1_Sub + 2#11_000_100#); + Gen_8 (Len); End_Insn; end Emit_Subl_Sp_Imm; - procedure Emit_Addl_Sp_Imm (Len : Byte) is + procedure Emit_Addl_Sp_Imm (Len : Byte) + is + pragma Assert (not Flags.M64); begin Start_Insn; - Gen_B8 (Opc_Grp1v_Rm_Imm8); - Gen_B8 (Opc2_Grp1_Add + 2#11_000_100#); - Gen_B8 (Len); + Gen_8 (Opc_Grp1v_Rm_Imm8); + Gen_8 (Opc2_Grp1_Add + 2#11_000_100#); + Gen_8 (Len); End_Insn; end Emit_Addl_Sp_Imm; @@ -1037,16 +1267,17 @@ package body Ortho_Code.X86.Emits is if Reg = R_St0 then -- fstp st, (esp) Start_Insn; - Gen_B8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); - Gen_B8 (2#00_011_100#); -- Modrm: SIB, no disp - Gen_B8 (2#00_100_100#); -- SIB: SS=0, no index, base=esp + Gen_8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); + Gen_8 (2#00_011_100#); -- Modrm: SIB, no disp + Gen_8 (2#00_100_100#); -- SIB: SS=0, no index, base=esp End_Insn; else pragma Assert (Reg in Regs_Xmm); Start_Insn; - Gen_SSE_Rep_Opc (Mode, 16#11#); - Gen_B8 (To_Reg_Xmm (Reg) * 8 + 2#00_000_100#); -- Modrm: [--] - Gen_B8 (2#00_100_100#); -- SIB: SS=0, no index, base=esp + Gen_SSE_Prefix (Mode); + Gen_SSE_Opc (Opc_Movsd_M64_Xmm); + Gen_8 (To_Reg_Xmm (Reg) * 8 + 2#00_000_100#); -- Modrm: [--] + Gen_8 (2#00_100_100#); -- SIB: SS=0, no index, base=esp End_Insn; end if; end Emit_Push_Fp; @@ -1075,19 +1306,19 @@ package body Ortho_Code.X86.Emits is Opc := To_Cond (Reg); if Val = 0 then -- Assume long jmp. - Gen_B8 (Opc_0f); - Gen_B8 (Opc2_0f_Jcc + Opc); - Gen_X86_Pc32 (Sym); + Gen_8 (Opc_0f); + Gen_8 (Opc2_0f_Jcc + Opc); + Gen_X86_Pc32 (Sym, 0); else if Val + 128 < Get_Current_Pc + 4 then -- Long jmp. - Gen_B8 (Opc_0f); - Gen_B8 (Opc2_0f_Jcc + Opc); - Gen_Le32 (Unsigned_32 (Val - (Get_Current_Pc + 4))); + Gen_8 (Opc_0f); + Gen_8 (Opc2_0f_Jcc + Opc); + Gen_32 (To_Unsigned_32 (Val - (Get_Current_Pc + 4))); else -- short jmp. - Gen_B8 (Opc_Jcc + Opc); - Gen_B8 (Byte (Val - (Get_Current_Pc + 1))); + Gen_8 (Opc_Jcc + Opc); + Gen_8 (Byte (Val - (Get_Current_Pc + 1))); end if; end if; End_Insn; @@ -1103,17 +1334,17 @@ package body Ortho_Code.X86.Emits is Start_Insn; if Val = 0 then -- Assume long jmp. - Gen_B8 (Opc_Jmp_Long); - Gen_X86_Pc32 (Sym); + Gen_8 (Opc_Jmp_Long); + Gen_X86_Pc32 (Sym, 0); else if Val + 128 < Get_Current_Pc + 4 then -- Long jmp. - Gen_B8 (Opc_Jmp_Long); - Gen_Le32 (Unsigned_32 (Val - (Get_Current_Pc + 4))); + Gen_8 (Opc_Jmp_Long); + Gen_32 (To_Unsigned_32 (Val - (Get_Current_Pc + 4))); else -- short jmp. - Gen_B8 (Opc_Jmp_Short); - Gen_B8 (Byte ((Val - (Get_Current_Pc + 1)) and 16#Ff#)); + Gen_8 (Opc_Jmp_Short); + Gen_8 (Byte ((Val - (Get_Current_Pc + 1)) and 16#Ff#)); end if; end if; End_Insn; @@ -1130,8 +1361,8 @@ package body Ortho_Code.X86.Emits is procedure Gen_Call (Sym : Symbol) is begin Start_Insn; - Gen_B8 (Opc_Call); - Gen_X86_Pc32 (Sym); + Gen_8 (Opc_Call); + Gen_X86_Pc32 (Sym, 0); End_Insn; end Gen_Call; @@ -1143,8 +1374,10 @@ package body Ortho_Code.X86.Emits is -- subl esp, val Emit_Subl_Sp_Imm (Byte (Val)); elsif Val < 0 then - Init_Modrm_Reg (R_Sp, Sz_32l); - Gen_Insn_Grp1 (Opc2_Grp1_Add, Sz_32l, -Val); + Start_Insn; + Init_Modrm_Reg (R_Sp, Sz_Ptr); + Gen_Insn_Grp1 (Opc2_Grp1_Add, -Val); + End_Insn; end if; end Emit_Stack_Adjust; @@ -1157,20 +1390,25 @@ package body Ortho_Code.X86.Emits is begin Gen_Call (Sym); - if Abi.Flag_Sse2 and then Mode in Mode_Fp then - -- Move from St0 to Xmm0. - -- fstp slot(%ebp) - Init_Modrm_Offset - (R_Bp, -Int32 (Cur_Subprg.Target.Fp_Slot), Sz_32l); - Start_Insn; - Gen_B8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); - Gen_Mod_Rm (2#00_011_000#); - End_Insn; - -- movsd slot(%ebp), %xmm0 - Start_Insn; - Gen_SSE_Rep_Opc (Mode, 16#10#); - Gen_Mod_Rm (2#00_000_000#); - End_Insn; + if Abi.Flag_Sse2 and then not Flags.M64 and then Mode in Mode_Fp then + declare + Sslot : constant Int32 := -Int32 (Cur_Subprg.Target.Fp_Slot); + begin + -- Move from St0 to Xmm0. + -- fstp slot(%ebp) + Start_Insn; + Init_Modrm_Offset (R_Bp, Sslot, Sz_Fp); + Gen_8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); + Gen_Mod_Rm_Opc (2#00_011_000#); + End_Insn; + -- movsd slot(%ebp), %xmm0 + Start_Insn; + Gen_SSE_Prefix (Mode); + Init_Modrm_Offset (R_Bp, Sslot, Sz_Fp); + Gen_SSE_Opc (Opc_Movsd_Xmm_M64); + Gen_Mod_Rm_Opc (2#00_000_000#); + End_Insn; + end; end if; end Emit_Call; @@ -1189,9 +1427,10 @@ package body Ortho_Code.X86.Emits is begin pragma Assert (Cond in Regs_Cc); Start_Insn; - Gen_B8 (Opc_0f); - Gen_B8 (Opc2_0f_Setcc + To_Cond (Cond)); - Gen_Rm (2#000_000#, Dest, Sz_8); + Init_Modrm_Expr (Dest, Sz_8); + Gen_8 (Opc_0f); + Gen_8 (Opc2_0f_Setcc + To_Cond (Cond)); + Gen_Mod_Rm_Opc (2#000_000#); End_Insn; end Emit_Setcc; @@ -1199,24 +1438,27 @@ package body Ortho_Code.X86.Emits is begin pragma Assert (Cond in Regs_Cc); Start_Insn; - Gen_B8 (Opc_0f); - Gen_B8 (Opc2_0f_Setcc + To_Cond (Cond)); - Gen_B8 (2#11_000_000# + To_Reg32 (Reg, Sz_8)); + Gen_8 (Opc_0f); + Gen_8 (Opc2_0f_Setcc + To_Cond (Cond)); + Gen_8 (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; + Init_Modrm_Reg (Reg, Sz, Reg, Sz); Gen_Insn_Sz (Opc_Test_Rm_Reg, Sz); - Gen_B8 (2#11_000_000# + To_Reg32 (Reg, Sz) * 9); + Gen_Mod_Rm_Reg; End_Insn; end Emit_Tst; procedure Gen_Cmp_Imm (Reg : O_Reg; Val : Int32; Sz : Insn_Size) is begin + Start_Insn; Init_Modrm_Reg (Reg, Sz); - Gen_Insn_Grp1 (Opc2_Grp1_Cmp, Sz, Val); + Gen_Insn_Grp1 (Opc2_Grp1_Cmp, Val); + End_Insn; end Gen_Cmp_Imm; procedure Emit_Spill (Stmt : O_Enode; Sz : Insn_Size) @@ -1226,10 +1468,10 @@ package body Ortho_Code.X86.Emits is begin -- A reload is missing. pragma Assert (Reg /= R_Spill); - Init_Modrm_Mem (Stmt, Sz); Start_Insn; + Init_Modrm_Mem (Stmt, Sz, Reg); Gen_Insn_Sz (Opc_Mov_Rm_Reg, Sz); - Gen_Mod_Rm (To_Reg32 (Reg, Sz) * 8); + Gen_Mod_Rm_Reg; End_Insn; end Emit_Spill; @@ -1241,10 +1483,11 @@ package body Ortho_Code.X86.Emits is -- A reload is missing. pragma Assert (Reg in Regs_Xmm); -- movsd - Init_Modrm_Mem (Stmt, Sz_32l); Start_Insn; - Gen_SSE_Rep_Opc (Mode, 16#11#); - Gen_Mod_Rm (To_Reg_Xmm (Reg) * 8); + Gen_SSE_Prefix (Mode); + Init_Modrm_Mem (Stmt, Sz_Fp, Reg); + Gen_SSE_Opc (Opc_Movsd_M64_Xmm); + Gen_Mod_Rm_Reg; End_Insn; end Emit_Spill_Xmm; @@ -1252,8 +1495,9 @@ package body Ortho_Code.X86.Emits is is begin Start_Insn; + Init_Modrm_Expr (Val, Sz, Reg); Gen_Insn_Sz (Opc_Mov_Reg_Rm, Sz); - Gen_Rm (To_Reg32 (Reg, Sz) * 8, Val, Sz); + Gen_Mod_Rm_Reg; End_Insn; end Emit_Load; @@ -1264,10 +1508,10 @@ package body Ortho_Code.X86.Emits is -- Hack: change the register to use the real address instead of it. Set_Expr_Reg (Stmt, R_Mem); - Init_Modrm_Mem (Stmt, Sz_32l); Start_Insn; - Gen_B8 (Opc_Leal_Reg_Rm); - Gen_Mod_Rm (To_Reg32 (Reg) * 8); + Init_Modrm_Mem (Stmt, Sz_Ptr, Reg); + Gen_8 (Opc_Leal_Reg_Rm); + Gen_Mod_Rm_Reg; End_Insn; -- Restore. @@ -1279,8 +1523,9 @@ package body Ortho_Code.X86.Emits is begin pragma Assert (Get_Expr_Reg (Get_Expr_Left (Stmt)) = R_Ax); Start_Insn; + Init_Modrm_Expr (Get_Expr_Right (Stmt), Sz); Gen_Insn_Sz (Opc_Grp3_Width, Sz); - Gen_Rm (Opc2_Grp3_Mul, Get_Expr_Right (Stmt), Sz); + Gen_Mod_Rm_Opc (Opc2_Grp3_Mul); End_Insn; end Gen_Umul; @@ -1291,30 +1536,32 @@ package body Ortho_Code.X86.Emits is Reg_R : O_Reg; begin pragma Assert (Get_Expr_Reg (Get_Expr_Left (Stmt)) = Reg); - pragma Assert (Sz = Sz_32l); Start_Insn; if Reg = R_Ax then + Init_Modrm_Expr (Right, Sz); Gen_Insn_Sz (Opc_Grp3_Width, Sz); - Gen_Rm (Opc2_Grp3_Mul, Right, Sz); + Gen_Mod_Rm_Opc (Opc2_Grp3_Mul); else Reg_R := Get_Expr_Reg (Right); case Reg_R is when R_Imm => + Init_Modrm_Reg (Reg, Sz, Reg, Sz); if Is_Imm8 (Right, Sz) then - Gen_B8 (Opc_Imul_Reg_Rm_Imm8); - Gen_B8 (To_Reg32 (Reg, Sz) * 9 or 2#11_000_000#); + Gen_8 (Opc_Imul_Reg_Rm_Imm8); + Gen_Mod_Rm_Reg; Gen_Imm8 (Right, Sz); else - Gen_B8 (Opc_Imul_Reg_Rm_Imm32); - Gen_B8 (To_Reg32 (Reg, Sz) * 9 or 2#11_000_000#); + Gen_8 (Opc_Imul_Reg_Rm_Imm32); + Gen_Mod_Rm_Reg; Gen_Imm (Right, Sz); end if; when R_Mem | R_Spill - | Regs_R32 => - Gen_B8 (Opc_0f); - Gen_B8 (Opc2_0f_Imul); - Gen_Rm (To_Reg32 (Reg, Sz) * 8, Right, Sz); + | Regs_R64 => + Init_Modrm_Expr (Right, Sz, Reg); + Gen_8 (Opc_0f); + Gen_8 (Opc2_0f_Imul); + Gen_Mod_Rm_Reg; when others => Error_Emit ("gen_mul", Stmt); end case; @@ -1331,90 +1578,142 @@ package body Ortho_Code.X86.Emits is Gen_2 (Opc_Int, 16#04#); end Gen_Ov_Check; + procedure Gen_Into is + begin + if Flags.M64 then + Gen_Ov_Check (R_No); + else + Gen_1 (Opc_Into); + end if; + end Gen_Into; + procedure Emit_Abs (Val : O_Enode; Mode : Mode_Type) is - Szh : Insn_Size; + Szl, Szh : Insn_Size; Pc_Jmp : Pc_Type; begin case Mode is when Mode_I32 => - Szh := Sz_32l; + Szh := Sz_32; + Szl := Sz_32; when Mode_I64 => - Szh := Sz_32h; + if Flags.M64 then + Szh := Sz_64; + Szl := Sz_64; + else + Szh := Sz_32h; + Szl := Sz_32l; + end if; when others => raise Program_Error; end case; Emit_Tst (Get_Expr_Reg (Val), Szh); - -- JXX + - Start_Insn; - Gen_B8 (Opc_Jcc + To_Cond (R_Sge)); - Gen_B8 (0); - End_Insn; + -- JGE xxx (skip if positive). + Gen_2 (Opc_Jcc + To_Cond (R_Sge), 0); Pc_Jmp := Get_Current_Pc; -- NEG - Gen_Grp3_Insn (Opc2_Grp3_Neg, Val, Sz_32l); - if Mode = Mode_I64 then + Gen_Grp3_Insn (Opc2_Grp3_Neg, Val, Szl); + if (not Flags.M64) and Mode = Mode_I64 then -- Propagate carry. -- Adc reg,0 -- neg reg - Init_Rm_Expr (Val, Sz_32h); - Gen_Insn_Grp1 (Opc2_Grp1_Adc, Sz_32h, 0); + Start_Insn; + Init_Modrm_Expr (Val, Sz_32h); + Gen_Insn_Grp1 (Opc2_Grp1_Adc, 0); + End_Insn; Gen_Grp3_Insn (Opc2_Grp3_Neg, Val, Sz_32h); end if; Gen_Into; - Patch_B8 (Pc_Jmp - 1, Unsigned_8 (Get_Current_Pc - Pc_Jmp)); + Patch_8 (Pc_Jmp - 1, Unsigned_8 (Get_Current_Pc - Pc_Jmp)); end Emit_Abs; procedure Gen_Alloca (Stmt : O_Enode) is Reg : constant O_Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt)); begin - pragma Assert (Reg in Regs_R32); + pragma Assert (Reg in Regs_R64); pragma Assert (Reg = Get_Expr_Reg (Stmt)); -- Align stack on word. -- Add reg, (stack_boundary - 1) Start_Insn; - Gen_B8 (Opc_Grp1v_Rm_Imm8); - Gen_B8 (Opc2_Grp1_Add or 2#11_000_000# or To_Reg32 (Reg)); - Gen_B8 (Byte (X86.Flags.Stack_Boundary - 1)); + Gen_Rex_B (Reg, Sz_Ptr); + Gen_8 (Opc_Grp1v_Rm_Imm8); + Gen_8 (Opc2_Grp1_Add or 2#11_000_000# or To_Reg32 (Reg)); + Gen_8 (Byte (X86.Flags.Stack_Boundary - 1)); End_Insn; -- and reg, ~(stack_boundary - 1) Start_Insn; - Gen_B8 (Opc_Grp1v_Rm_Imm32); - Gen_B8 (Opc2_Grp1_And or 2#11_000_000# or To_Reg32 (Reg)); - Gen_Le32 (not (X86.Flags.Stack_Boundary - 1)); + Gen_Rex_B (Reg, Sz_Ptr); + Gen_8 (Opc_Grp1v_Rm_Imm32); + Gen_8 (Opc2_Grp1_And or 2#11_000_000# or To_Reg32 (Reg)); + Gen_32 (not (X86.Flags.Stack_Boundary - 1)); End_Insn; if X86.Flags.Flag_Alloca_Call then Gen_Call (Chkstk_Symbol); else -- subl esp, reg - Gen_2 (Opc_Subl_Reg_Rm, 2#11_100_000# + To_Reg32 (Reg)); + Start_Insn; + Gen_Rex_B (Reg, Sz_Ptr); + Gen_8 (Opc_Subl_Reg_Rm); + Gen_8 (2#11_100_000# + To_Reg32 (Reg)); + End_Insn; end if; -- movl reg, esp - Gen_2 (Opc_Mov_Rm_Reg + 1, 2#11_100_000# + To_Reg32 (Reg)); + Start_Insn; + Gen_Rex_B (Reg, Sz_Ptr); + Gen_8 (Opc_Mov_Rm_Reg + 1); + Gen_8 (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; + procedure Gen_Movzx (Reg : Regs_R64; Op : O_Enode; Dst_Sz : Insn_Size) is begin Start_Insn; - Gen_B8 (Opc_0f); - case Sz is - when Sz_8 => - B := 0; - when Sz_16 => - B := 1; - when Sz_32l - | Sz_32h => + Init_Modrm_Expr (Op, Dst_Sz, Reg); + Gen_8 (Opc_0f); + case Get_Expr_Mode (Op) is + when Mode_I8 | Mode_U8 | Mode_B2 => + Gen_8 (Opc2_0f_Movzx); + when Mode_I16 | Mode_U16 => + Gen_8 (Opc2_0f_Movzx + 1); + when others => raise Program_Error; end case; - Gen_B8 (Opc2_0f_Movzx + B); - Gen_Rm (To_Reg32 (Reg) * 8, Op, Sz_8); + Gen_Mod_Rm_Reg; End_Insn; end Gen_Movzx; + procedure Gen_Movsxd (Src : O_Reg; Dst : O_Reg) is + begin + Start_Insn; + Init_Modrm_Reg (Src, Sz_64, Dst, Sz_64); + Gen_8 (Opc_Movsxd_Reg_Rm); + Gen_Mod_Rm_Reg; + End_Insn; + end Gen_Movsxd; + + procedure Emit_Move (Operand : O_Enode; Sz : Insn_Size; Reg : O_Reg) is + begin + -- mov REG, OP + Start_Insn; + Init_Modrm_Expr (Operand, Sz, Reg); + Gen_Insn_Sz (Opc_Mov_Reg_Rm, Sz); + Gen_Mod_Rm_Reg; + End_Insn; + end Emit_Move; + + procedure Emit_Move_Xmm (Operand : O_Enode; Mode : Mode_Fp; Reg : O_Reg) is + begin + -- movsd REG, OP + Start_Insn; + Gen_SSE_Prefix (Mode); + Init_Modrm_Expr (Operand, Sz_Fp, Reg); + Gen_SSE_Opc (Opc_Movsd_Xmm_M64); + Gen_Mod_Rm_Reg; + End_Insn; + end Emit_Move_Xmm; + -- Convert U32 to xx. procedure Gen_Conv_U32 (Stmt : O_Enode) is @@ -1426,26 +1725,31 @@ package body Ortho_Code.X86.Emits is when Mode_I32 => pragma Assert (Reg_Res in Regs_R32); if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); + Emit_Load (Reg_Res, Op, Sz_32); end if; - Emit_Tst (Reg_Res, Sz_32l); + Emit_Tst (Reg_Res, Sz_32); Gen_Ov_Check (R_Sge); when Mode_I64 => - pragma Assert (Reg_Res = R_Edx_Eax); - pragma Assert (Reg_Op = R_Ax); - -- Clear edx. - Gen_Clear_Edx; + if Flags.M64 then + Emit_Move (Op, Sz_32, Reg_Res); + else + pragma Assert (Reg_Res = R_Edx_Eax); + pragma Assert (Reg_Op = R_Ax); + -- Clear edx. + Gen_Clear_Edx; + end if; when Mode_U8 | Mode_B2 => pragma Assert (Reg_Res in Regs_R32); if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); + Emit_Load (Reg_Res, Op, Sz_32); end if; -- cmpl VAL, 0xff Start_Insn; - Gen_B8 (Opc_Grp1v_Rm_Imm32); - Gen_Rm (Opc2_Grp1_Cmp, Op, Sz_32l); - Gen_Le32 (16#00_00_00_Ff#); + Init_Modrm_Expr (Op, Sz_32); + Gen_8 (Opc_Grp1v_Rm_Imm32); + Gen_Mod_Rm_Opc (Opc2_Grp1_Cmp); + Gen_32 (16#00_00_00_Ff#); End_Insn; Gen_Ov_Check (R_Ule); when others => @@ -1462,42 +1766,47 @@ package body Ortho_Code.X86.Emits is begin case Get_Expr_Mode (Stmt) is when Mode_I64 => - pragma Assert (Reg_Res = R_Edx_Eax); - pragma Assert (Reg_Op = R_Ax); - Gen_Cdq; + if Flags.M64 then + Gen_Movsxd (Reg_Op, Reg_Res); + else + pragma Assert (Reg_Res = R_Edx_Eax); + pragma Assert (Reg_Op = R_Ax); + Gen_Cdq (Sz_32); + end if; when Mode_U32 => pragma Assert (Reg_Res in Regs_R32); if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); + Emit_Load (Reg_Res, Op, Sz_32); end if; - Emit_Tst (Reg_Res, Sz_32l); + Emit_Tst (Reg_Res, Sz_32); Gen_Ov_Check (R_Sge); when Mode_B2 => if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); + Emit_Load (Reg_Res, Op, Sz_32); end if; - Gen_Cmp_Imm (Reg_Res, 1, Sz_32l); + Gen_Cmp_Imm (Reg_Res, 1, Sz_32); Gen_Ov_Check (R_Ule); when Mode_U8 => if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); + Emit_Load (Reg_Res, Op, Sz_32); end if; - Gen_Cmp_Imm (Reg_Res, 16#Ff#, Sz_32l); + Gen_Cmp_Imm (Reg_Res, 16#Ff#, Sz_32); Gen_Ov_Check (R_Ule); when Mode_F64 => if Reg_Res in Regs_Xmm then -- cvtsi2sd - Init_Rm_Expr (Op, Sz_32l); - Gen_SSE_Rep_Opc (Mode_F64, 16#2a#); - Gen_Mod_Rm (To_Reg_Xmm (Reg_Res) * 8); + Gen_SSE_Prefix (Mode_F64); + Init_Modrm_Expr (Op, Sz_32, Reg_Res); + Gen_SSE_Opc (Opc_Cvtsi2sd_Xmm_Rm); + Gen_Mod_Rm_Reg; End_Insn; else - Emit_Push_32 (Op, Sz_32l); + Emit_Push (Op, Sz_32); -- fild (%esp) Start_Insn; - Gen_B8 (2#11011_011#); - Gen_B8 (2#00_000_100#); - Gen_B8 (2#00_100_100#); + Gen_8 (2#11011_011#); + Gen_8 (2#00_000_100#); + Gen_8 (2#00_100_100#); End_Insn; -- addl %esp, 4 Emit_Addl_Sp_Imm (4); @@ -1510,24 +1819,29 @@ package body Ortho_Code.X86.Emits is -- Convert U8 to xxx procedure Gen_Conv_U8 (Stmt : O_Enode) is + Mode : constant Mode_Type := Get_Expr_Mode (Stmt); Op : constant O_Enode := Get_Expr_Operand (Stmt); Reg_Res : constant O_Reg := Get_Expr_Reg (Stmt); Reg_Op : constant O_Reg := Get_Expr_Reg (Op); begin - case Get_Expr_Mode (Stmt) is + case Mode is when Mode_U32 | Mode_I32 | Mode_U16 | Mode_I16 => - pragma Assert (Reg_Res in Regs_R32); - Gen_Movzx (Reg_Res, Op, Sz_8); + pragma Assert (Reg_Res in Regs_R64); + Gen_Movzx (Reg_Res, Op, Int_Mode_To_Size (Mode)); when Mode_I64 | Mode_U64 => - pragma Assert (Reg_Res = R_Edx_Eax); - pragma Assert (Reg_Op = R_Ax); - Gen_Movzx (R_Ax, Op, Sz_8); - -- Sign-extend, but we know the sign is positive. - Gen_Cdq; + if Flags.M64 then + Gen_Movzx (Reg_Res, Op, Sz_64); + else + pragma Assert (Reg_Res = R_Edx_Eax); + pragma Assert (Reg_Op = R_Ax); + Gen_Movzx (R_Ax, Op, Sz_32); + -- Sign-extend, but we know the sign is positive. + Gen_Cdq (Sz_32); + end if; when others => Error_Emit ("gen_conv_U8", Stmt); end case; @@ -1536,23 +1850,28 @@ package body Ortho_Code.X86.Emits is -- Convert B2 to xxx procedure Gen_Conv_B2 (Stmt : O_Enode) is + Mode : constant Mode_Type := Get_Expr_Mode (Stmt); Op : constant O_Enode := Get_Expr_Operand (Stmt); Reg_Op : constant O_Reg := Get_Expr_Reg (Op); Reg_Res : constant O_Reg := Get_Expr_Reg (Stmt); begin - case Get_Expr_Mode (Stmt) is + case Mode is when Mode_U32 | Mode_I32 | Mode_U16 | Mode_I16 => - pragma Assert (Reg_Res in Regs_R32); - Gen_Movzx (Reg_Res, Op, Sz_8); + pragma Assert (Reg_Res in Regs_R64); + Gen_Movzx (Reg_Res, Op, Int_Mode_To_Size (Mode)); when Mode_I64 => - pragma Assert (Reg_Res = R_Edx_Eax); - pragma Assert (Reg_Op = R_Ax); - Gen_Movzx (R_Ax, Op, Sz_8); - -- Sign-extend, but we know the sign is positive. - Gen_Cdq; + if Flags.M64 then + Gen_Movzx (Reg_Res, Op, Sz_64); + else + pragma Assert (Reg_Res = R_Edx_Eax); + pragma Assert (Reg_Op = R_Ax); + Gen_Movzx (R_Ax, Op, Sz_32); + -- Sign-extend, but we know the sign is positive. + Gen_Cdq (Sz_32); + end if; when others => Error_Emit ("gen_conv_B2", Stmt); end case; @@ -1561,75 +1880,111 @@ package body Ortho_Code.X86.Emits is -- Convert I64 to xxx procedure Gen_Conv_I64 (Stmt : O_Enode) is + Mode : constant Mode_Type := Get_Expr_Mode (Stmt); Op : constant O_Enode := Get_Expr_Operand (Stmt); Reg_Op : constant O_Reg := Get_Expr_Reg (Op); Reg_Res : constant O_Reg := Get_Expr_Reg (Stmt); begin - case Get_Expr_Mode (Stmt) is + case Mode is when Mode_I32 => - pragma Assert (Reg_Op = R_Edx_Eax); - pragma Assert (Reg_Res = R_Ax); - -- move dx to reg_helper - Start_Insn; - Gen_B8 (Opc_Mov_Rm_Reg + 1); - Gen_B8 (2#11_010_000# + To_Reg32 (Reg_Helper)); - End_Insn; - -- Sign extend eax. - Gen_Cdq; - -- cmp reg_helper, dx - Start_Insn; - Gen_B8 (Opc_Cmpl_Rm_Reg); - Gen_B8 (2#11_010_000# + To_Reg32 (Reg_Helper)); - End_Insn; - -- Overflow if extended value is different from initial value. - Gen_Ov_Check (R_Eq); - when Mode_U8 => - pragma Assert (Reg_Op in Regs_R64); - -- Check MSB = 0 - Emit_Tst (Reg_Op, Sz_32h); - Gen_Ov_Check (R_Eq); - -- Check LSB <= 255 - if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); + if Flags.M64 then + -- movsxd src, dst + Gen_Movsxd (Reg_Op, Reg_Res); + -- cmp src,dst + Start_Insn; + Init_Modrm_Reg (Reg_Op, Sz_64, Reg_Res, Sz_64); + Gen_8 (Opc_Cmpl_Rm_Reg); + Gen_Mod_Rm_Reg; + End_Insn; + else + pragma Assert (Reg_Op = R_Edx_Eax); + pragma Assert (Reg_Res = R_Ax); + -- move dx to reg_helper + Start_Insn; + Gen_8 (Opc_Mov_Rm_Reg + 1); + Gen_8 (2#11_010_000# + To_Reg32 (Reg_Helper)); + End_Insn; + -- Sign extend eax. + Gen_Cdq (Sz_32); + -- cmp reg_helper, dx + Start_Insn; + Gen_8 (Opc_Cmpl_Rm_Reg); + Gen_8 (2#11_010_000# + To_Reg32 (Reg_Helper)); + End_Insn; end if; - Gen_Cmp_Imm (Reg_Res, 16#Ff#, Sz_32l); - Gen_Ov_Check (R_Ule); - when Mode_B2 => - pragma Assert (Reg_Op in Regs_R64); - -- Check MSB = 0 - Emit_Tst (Reg_Op, Sz_32h); + -- Overflow if extended value is different from initial value. Gen_Ov_Check (R_Eq); - -- Check LSB <= 1 - if Reg_Op /= Reg_Res then - Emit_Load (Reg_Res, Op, Sz_32l); - end if; - Gen_Cmp_Imm (Reg_Res, 16#1#, Sz_32l); + when Mode_U8 + | Mode_B2 => + declare + Ubound : Int32; + begin + if Mode = Mode_B2 then + Ubound := 1; + else + Ubound := 16#ff#; + end if; + + if Flags.M64 then + Emit_Load (Reg_Res, Op, Sz_64); + Start_Insn; + Init_Modrm_Reg (Reg_Res, Sz_64); + Gen_Insn_Grp1 (Opc2_Grp1_Cmp, Ubound); + End_Insn; + else + pragma Assert (Reg_Op in Regs_Pair); + -- Check MSB = 0 + Emit_Tst (Reg_Op, Sz_32h); + Gen_Ov_Check (R_Eq); + -- Check LSB <= 255 (U8) or LSB <= 1 (B2) + if Reg_Op /= Reg_Res then + -- Move reg_op -> reg_res + -- FIXME: factorize with OE_Mov. + Start_Insn; + Init_Modrm_Reg (Reg_Op, Sz_32l, Reg_Res); + Gen_Insn_Sz (Opc_Mov_Reg_Rm, Sz_32); + Gen_Mod_Rm_Reg; + End_Insn; + end if; + Gen_Cmp_Imm (Reg_Res, Ubound, Sz_32); + end if; + end; Gen_Ov_Check (R_Ule); 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; - if Reg_Res in Regs_Xmm then - -- fstp (%esp) - Start_Insn; - Gen_B8 (2#11011_00_1# + Mode_Fp_To_Mf (Mode_F64)); - Gen_B8 (2#00_011_100#); - Gen_B8 (2#00_100_100#); + if Flags.M64 then + -- cvtsi2sd + Gen_SSE_Prefix (Mode_F64); + Init_Modrm_Expr (Op, Sz_64, Reg_Res); + Gen_SSE_Opc (Opc_Cvtsi2sd_Xmm_Rm); + Gen_Mod_Rm_Reg; End_Insn; - -- movsd (%esp), %xmm + else + Emit_Push (Op, Sz_32h); + Emit_Push (Op, Sz_32l); + -- fild (%esp) Start_Insn; - Gen_SSE_Rep_Opc (Mode_F64, 16#10#); - Gen_B8 (To_Reg_Xmm (Reg_Res) * 8 + 2#00_000_100#); - Gen_B8 (2#00_100_100#); + Gen_8 (2#11011_111#); + Gen_8 (2#00_101_100#); + Gen_8 (2#00_100_100#); End_Insn; + if Reg_Res in Regs_Xmm then + -- fstp (%esp) + Start_Insn; + Gen_8 (2#11011_00_1# + Mode_Fp_To_Mf (Mode_F64)); + Gen_8 (2#00_011_100#); + Gen_8 (2#00_100_100#); + End_Insn; + -- movsd (%esp), %xmm + Start_Insn; + Gen_SSE_Prefix (Mode_F64); + Gen_SSE_Opc (Opc_Movsd_Xmm_M64); + Gen_8 (To_Reg_Xmm (Reg_Res) * 8 + 2#00_000_100#); + Gen_8 (2#00_100_100#); + End_Insn; + end if; + -- addl %esp, 8 + Emit_Addl_Sp_Imm (8); end if; - -- addl %esp, 8 - Emit_Addl_Sp_Imm (8); when others => Error_Emit ("gen_conv_I64", Stmt); end case; @@ -1641,29 +1996,33 @@ package body Ortho_Code.X86.Emits is Mode : constant Mode_Type := Get_Expr_Mode (Stmt); Reg : constant O_Reg := Get_Expr_Reg (Stmt); Reg_Op : constant O_Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt)); + Sslot : constant Int32 := -Int32 (Cur_Subprg.Target.Fp_Slot); begin - if Mode = Mode_I32 and then Reg_Op in Regs_Xmm then + if Abi.Flag_Sse2 and then + (Mode = Mode_I32 or (Flags.M64 and Mode = Mode_I64)) + then -- cvtsd2si - Init_Modrm_Reg (Reg_Op, Sz_32l); - Gen_SSE_Rep_Opc (Mode_F64, 16#2d#); - Gen_Mod_Rm (To_Reg32 (Reg) * 8); + Gen_SSE_Prefix (Mode_F64); + Init_Modrm_Reg (Reg_Op, Int_Mode_To_Size (Mode), Reg); + Gen_SSE_Opc (Opc_Cvtsd2si_Reg_Xm); + Gen_Mod_Rm_Reg; End_Insn; return; end if; - Init_Modrm_Offset - (R_Bp, -Int32 (Cur_Subprg.Target.Fp_Slot), Sz_32l); - if Reg_Op in Regs_Xmm then -- movsd %xmm, (%ebp), Start_Insn; - Gen_SSE_Rep_Opc (Mode_F64, 16#11#); - Gen_Mod_Rm (To_Reg_Xmm (Reg_Op) * 8); + Gen_SSE_Prefix (Mode_F64); + Init_Modrm_Offset (R_Bp, Sslot, Sz_Ptr, Reg_Op); + Gen_SSE_Opc (Opc_Movsd_M64_Xmm); + Gen_Mod_Rm_Reg; End_Insn; -- fldl slot(%ebp) Start_Insn; - Gen_B8 (2#11011_00_1# + Mode_Fp_To_Mf (Mode_F64)); - Gen_Mod_Rm (2#00_000_000#); + Init_Modrm_Offset (R_Bp, Sslot, Sz_Ptr); + Gen_8 (2#11011_00_1# + Mode_Fp_To_Mf (Mode_F64)); + Gen_Mod_Rm_Opc (2#00_000_000#); End_Insn; end if; @@ -1671,32 +2030,31 @@ package body Ortho_Code.X86.Emits is when Mode_I32 => -- fistpl slot(%ebp) Start_Insn; - Gen_B8 (2#11011_011#); - Gen_Mod_Rm (2#00_011_000#); + Init_Modrm_Offset (R_Bp, Sslot, Sz_32); + Gen_8 (2#11011_011#); + Gen_Mod_Rm_Opc (2#00_011_000#); End_Insn; -- movl slot(%ebp), reg - -- Keep same modrm parameters. Start_Insn; - Gen_B8 (Opc_Movl_Reg_Rm); - Gen_Mod_Rm (To_Reg32 (Reg, Sz_32l) * 8); + Init_Modrm_Offset (R_Bp, Sslot, Sz_32, Reg); + Gen_8 (Opc_Movl_Reg_Rm); + Gen_Mod_Rm_Reg; End_Insn; when Mode_I64 => -- fistpq slot(%ebp) Start_Insn; - Gen_B8 (2#11011_111#); - Gen_Mod_Rm (2#00_111_000#); + Init_Modrm_Offset (R_Bp, Sslot, Sz_32); + Gen_8 (2#11011_111#); + Gen_Mod_Rm_Opc (2#00_111_000#); End_Insn; -- movl slot(%ebp), reg - -- Keep same modrm parameters. - Start_Insn; - Gen_B8 (Opc_Movl_Reg_Rm); - Gen_Mod_Rm (To_Reg32 (Reg, Sz_32l) * 8); - End_Insn; - Rm_Offset := Rm_Offset + 4; - Start_Insn; - Gen_B8 (Opc_Movl_Reg_Rm); - Gen_Mod_Rm (To_Reg32 (Reg, Sz_32h) * 8); - End_Insn; + for Sz in Sz_32l .. Sz_32h loop + Start_Insn; + Init_Modrm_Offset (R_Bp, Sslot, Sz, Reg); + Gen_8 (Opc_Movl_Reg_Rm); + Gen_Mod_Rm_Reg; + End_Insn; + end loop; when others => Error_Emit ("gen_conv_fp", Stmt); end case; @@ -1708,11 +2066,15 @@ package body Ortho_Code.X86.Emits is when Mode_U32 | Mode_I32 | Mode_P32 => - Gen_Grp1_Insn (Cl, Stmt, Sz_32l); + Gen_Grp1_Insn (Cl, Stmt, Sz_32); when Mode_I64 | Mode_U64 => - Gen_Grp1_Insn (Cl, Stmt, Sz_32l); - Gen_Grp1_Insn (Ch, Stmt, Sz_32h); + if Flags.M64 then + Gen_Grp1_Insn (Cl, Stmt, Sz_64); + else + Gen_Grp1_Insn (Cl, Stmt, Sz_32l); + Gen_Grp1_Insn (Ch, Stmt, Sz_32h); + end if; when Mode_B2 | Mode_I8 | Mode_U8 => @@ -1743,17 +2105,15 @@ package body Ortho_Code.X86.Emits is procedure Gen_Emit_Fp_Op (Stmt : O_Enode; Fp_Op : Byte) is - Right : O_Enode; - Reg : O_Reg; + Right : constant O_Enode := Get_Expr_Right (Stmt); + Reg : constant O_Reg := Get_Expr_Reg (Right); 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 Fp_Op); + Gen_8 (2#11011_110#); + Gen_8 (2#11_000_001# or Fp_Op); when R_Mem => case Get_Expr_Mode (Stmt) is when Mode_F32 => @@ -1763,9 +2123,9 @@ package body Ortho_Code.X86.Emits is when others => raise Program_Error; end case; - Gen_B8 (2#11011_000# or B_Size); - Init_Modrm_Mem (Right, Sz_32l); - Gen_Mod_Rm (Fp_Op); + Init_Modrm_Mem (Right, Sz_Ptr); + Gen_8 (2#11011_000# or B_Size); + Gen_Mod_Rm_Opc (Fp_Op); when others => raise Program_Error; end case; @@ -1782,15 +2142,19 @@ package body Ortho_Code.X86.Emits is Mode : constant Mode_Type := Get_Expr_Mode (Stmt); Right : constant O_Enode := Get_Expr_Right (Stmt); begin - Init_Rm_Expr (Right, Sz_32l); - Gen_Xmm_Modrm (Mode, Xmm_Op, Reg); + Start_Insn; + Gen_SSE_Prefix (Mode); + Init_Modrm_Expr (Right, Sz_32, Reg); + Gen_SSE_Opc (Xmm_Op); + Gen_Mod_Rm_Reg; + End_Insn; end; else Gen_Emit_Fp_Op (Stmt, Fp_Op); end if; end Gen_Emit_Fp_Or_Xmm_Op; - procedure Emit_Mod (Stmt : O_Enode) + procedure Emit_Mod (Stmt : O_Enode; Sz : Insn_Size) is Right : O_Enode; Pc1, Pc2, Pc3: Pc_Type; @@ -1812,36 +2176,42 @@ package body Ortho_Code.X86.Emits is -- end if Right := Get_Expr_Right (Stmt); -- %edx <- right - Emit_Load (R_Dx, Right, Sz_32l); + Emit_Load (R_Dx, Right, Sz); -- xorl %eax -> %edx Start_Insn; - Gen_B8 (Opc_Xorl_Rm_Reg); - Gen_B8 (2#11_000_010#); + Gen_Rex_B (R_None, Sz); + Gen_8 (Opc_Xorl_Rm_Reg); + Gen_8 (2#11_000_010#); End_Insn; - Gen_Cdq; + Gen_Cdq (Sz); -- js Gen_2 (Opc_Jcc + 2#1000#, 0); Pc1 := Get_Current_Pc; -- idiv - Gen_Grp3_Insn (Opc2_Grp3_Idiv, Right, Sz_32l); + Gen_Grp3_Insn (Opc2_Grp3_Idiv, Right, Sz); -- jmp Gen_2 (Opc_Jmp_Short, 0); Pc2 := Get_Current_Pc; - Patch_B8 (Pc1 - 1, Unsigned_8 (Get_Current_Pc - Pc1)); + Patch_8 (Pc1 - 1, Unsigned_8 (Get_Current_Pc - Pc1)); -- idiv - Gen_Grp3_Insn (Opc2_Grp3_Idiv, Right, Sz_32l); + Gen_Grp3_Insn (Opc2_Grp3_Idiv, Right, Sz); -- tstl %edx,%edx - Gen_2 (Opc_Test_Rm_Reg + 1, 2#11_010_010#); + Start_Insn; + Gen_Rex_B (R_None, Sz); + Gen_8 (Opc_Test_Rm_Reg + 1); + Gen_8 (2#11_010_010#); + End_Insn; -- jz Gen_2 (Opc_Jcc + 2#0100#, 0); Pc3 := Get_Current_Pc; -- addl b, %edx Start_Insn; - Gen_B8 (Opc_Addl_Reg_Rm); - Gen_Rm (2#010_000#, Right, Sz_32l); + Init_Modrm_Expr (Right, Sz, R_Dx); + Gen_8 (Opc_Addl_Reg_Rm); + Gen_Mod_Rm_Reg; End_Insn; - Patch_B8 (Pc2 - 1, Unsigned_8 (Get_Current_Pc - Pc2)); - Patch_B8 (Pc3 - 1, Unsigned_8 (Get_Current_Pc - Pc3)); + Patch_8 (Pc2 - 1, Unsigned_8 (Get_Current_Pc - Pc2)); + Patch_8 (Pc3 - 1, Unsigned_8 (Get_Current_Pc - Pc3)); end Emit_Mod; procedure Emit_Insn (Stmt : O_Enode) @@ -1894,10 +2264,14 @@ package body Ortho_Code.X86.Emits is when Mode_U16 => Gen_Umul (Stmt, Sz_16); when Mode_U32 => - Gen_Mul (Stmt, Sz_32l); + Gen_Mul (Stmt, Sz_32); when Mode_I32 => - Gen_Grp3_Insn (Opc2_Grp3_Imul, - Get_Expr_Right (Stmt), Sz_32l); + Gen_Grp3_Insn (Opc2_Grp3_Imul, Get_Expr_Right (Stmt), Sz_32); + when Mode_I64 => + Gen_Grp3_Insn (Opc2_Grp3_Imul, Get_Expr_Right (Stmt), Sz_64); + when Mode_U64 => + pragma Assert (Flags.M64); + Gen_Mul (Stmt, Sz_64); when Mode_F32 | Mode_F64 => Gen_Emit_Fp_Or_Xmm_Op (Stmt, 2#001_000#, 16#59#); @@ -1912,7 +2286,7 @@ package body Ortho_Code.X86.Emits is begin case Mode is when Mode_U32 => - Sz := Sz_32l; + Sz := Sz_32; when others => Error_Emit ("emit_insn: shl", Stmt); end case; @@ -1920,20 +2294,22 @@ package body Ortho_Code.X86.Emits is if Get_Expr_Kind (Right) = OE_Const then Val := Get_Expr_Low (Right); Start_Insn; + Init_Modrm_Expr (Get_Expr_Left (Stmt), Sz); if Val = 1 then Gen_Insn_Sz (2#1101000_0#, Sz); - Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); + Gen_Mod_Rm_Opc (2#100_000#); else Gen_Insn_Sz (2#1100000_0#, Sz); - Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); - Gen_B8 (Byte (Val and 31)); + Gen_Mod_Rm_Opc (2#100_000#); + Gen_8 (Byte (Val and 31)); end if; End_Insn; else pragma Assert (Get_Expr_Reg (Right) = R_Cx); Start_Insn; + Init_Modrm_Expr (Get_Expr_Left (Stmt), Sz); Gen_Insn_Sz (2#1101001_0#, Sz); - Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz); + Gen_Mod_Rm_Opc (2#100_000#); End_Insn; end if; end; @@ -1941,17 +2317,24 @@ package body Ortho_Code.X86.Emits is | OE_Rem | OE_Div_Ov => case Mode is - when Mode_U32 => + when Mode_U32 + | Mode_U64 => Gen_Clear_Edx; - Gen_Grp3_Insn (Opc2_Grp3_Div, Get_Expr_Right (Stmt), Sz_32l); - when Mode_I32 => - if Kind = OE_Mod then - Emit_Mod (Stmt); - else - Gen_Cdq; - Gen_Grp3_Insn - (Opc2_Grp3_Idiv, Get_Expr_Right (Stmt), Sz_32l); - end if; + Gen_Grp3_Insn (Opc2_Grp3_Div, Get_Expr_Right (Stmt), + Int_Mode_To_Size (Mode)); + when Mode_I32 + | Mode_I64 => + declare + Sz : constant Insn_Size := Int_Mode_To_Size (Mode); + begin + if Kind = OE_Mod then + Emit_Mod (Stmt, Sz); + else + Gen_Cdq (Sz); + Gen_Grp3_Insn + (Opc2_Grp3_Idiv, Get_Expr_Right (Stmt), Sz); + end if; + end; when Mode_F32 | Mode_F64 => -- No Mod or Rem for fp types. @@ -1966,19 +2349,24 @@ package body Ortho_Code.X86.Emits is when Mode_B2 => -- Xor VAL, $1 Start_Insn; - Gen_B8 (Opc_Grp1v_Rm_Imm8); - Gen_Rm (Opc2_Grp1_Xor, Stmt, Sz_8); - Gen_B8 (16#01#); + Init_Modrm_Expr (Stmt, Sz_8); + Gen_8 (Opc_Grp1v_Rm_Imm8); + Gen_Mod_Rm_Opc (Opc2_Grp1_Xor); + Gen_8 (16#01#); End_Insn; when Mode_U8 => Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_8); when Mode_U16 => Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_16); when Mode_U32 => - Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_32l); + Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_32); when Mode_U64 => - Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_32l); - Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_32h); + if Flags.M64 then + Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_64); + else + Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_32l); + Gen_Grp3_Insn_Stmt (Opc2_Grp3_Not, Stmt, Sz_32h); + end if; when others => Error_Emit ("emit_insn: not", Stmt); end case; @@ -1992,27 +2380,32 @@ package body Ortho_Code.X86.Emits is Gen_Grp3_Insn_Stmt (Opc2_Grp3_Neg, Stmt, Sz_16); --Gen_Into; when Mode_I32 => - Gen_Grp3_Insn_Stmt (Opc2_Grp3_Neg, Stmt, Sz_32l); + Gen_Grp3_Insn_Stmt (Opc2_Grp3_Neg, Stmt, Sz_32); --Gen_Into; when Mode_I64 => - Gen_Grp3_Insn_Stmt (Opc2_Grp3_Neg, Stmt, Sz_32l); - -- adcl 0, high - Start_Insn; - Gen_B8 (Opc_Grp1v_Rm_Imm8); - Gen_Rm (Opc2_Grp1_Adc, Get_Expr_Operand (Stmt), Sz_32h); - Gen_B8 (0); - End_Insn; - Gen_Grp3_Insn_Stmt (Opc2_Grp3_Neg, Stmt, Sz_32h); - --Gen_Into; + if Flags.M64 then + Gen_Grp3_Insn_Stmt (Opc2_Grp3_Neg, Stmt, Sz_64); + else + Gen_Grp3_Insn_Stmt (Opc2_Grp3_Neg, Stmt, Sz_32l); + -- adcl 0, high + Start_Insn; + Init_Modrm_Expr (Get_Expr_Operand (Stmt), Sz_32h); + Gen_8 (Opc_Grp1v_Rm_Imm8); + Gen_Mod_Rm_Opc (Opc2_Grp1_Adc); + Gen_8 (0); + End_Insn; + Gen_Grp3_Insn_Stmt (Opc2_Grp3_Neg, Stmt, Sz_32h); + --Gen_Into; + end if; when Mode_F32 | Mode_F64 => Reg := Get_Expr_Reg (Stmt); if Reg in Regs_Xmm then -- Xorp{sd} reg, cst - Init_Modrm_Sym (Get_Xmm_Sign_Constant (Mode), Sz_32l); Start_Insn; + Init_Modrm_Sym (Get_Xmm_Sign_Constant (Mode), Sz_32, Reg); Gen_SSE_D16_Opc (Mode, Opc2_0f_Xorp); - Gen_Mod_Rm (Xmm_To_Modrm_Reg (Reg)); + Gen_Mod_Rm_Reg; End_Insn; else -- fchs @@ -2032,10 +2425,10 @@ package body Ortho_Code.X86.Emits is Reg := Get_Expr_Reg (Stmt); if Reg in Regs_Xmm then -- Andp{sd} reg, cst - Init_Modrm_Sym (Get_Xmm_Mask_Constant (Mode), Sz_32l); Start_Insn; + Init_Modrm_Sym (Get_Xmm_Mask_Constant (Mode), Sz_32, Reg); Gen_SSE_D16_Opc (Mode, Opc2_0f_Andp); - Gen_Mod_Rm (Xmm_To_Modrm_Reg (Reg)); + Gen_Mod_Rm_Reg; End_Insn; else -- fabs @@ -2054,65 +2447,70 @@ package body Ortho_Code.X86.Emits is when Mode_U32 | Mode_I32 | Mode_P32 => - Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32l); + Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32); when Mode_B2 | Mode_I8 | Mode_U8 => Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_8); - when Mode_U64 => - declare - Pc : Pc_Type; - begin - Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32h); - -- jne - Start_Insn; - Gen_B8 (Opc_Jcc + 2#0101#); - Gen_B8 (0); - End_Insn; - Pc := Get_Current_Pc; - Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32l); - Patch_B8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc)); - end; + when Mode_U64 + | Mode_P64 => + if Flags.M64 then + Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_64); + else + declare + Pc : Pc_Type; + begin + Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32h); + -- jne + Gen_2 (Opc_Jcc + 2#0101#, 0); + Pc := Get_Current_Pc; + Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32l); + Patch_8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc)); + end; + end if; when Mode_I64 => - declare - Pc : Pc_Type; - begin - Reg := Get_Expr_Reg (Stmt); - Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32h); - -- Note: this does not clobber a reg due to care in - -- insns. - Emit_Setcc_Reg (Reg, Insns.Ekind_Signed_To_Cc (Kind)); - -- jne - Start_Insn; - Gen_B8 (Opc_Jcc + 2#0101#); - Gen_B8 (0); - End_Insn; - Pc := Get_Current_Pc; - Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32l); - Emit_Setcc_Reg - (Reg, Insns.Ekind_Unsigned_To_Cc (Kind)); - Patch_B8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc)); - return; - end; + if Flags.M64 then + Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_64); + else + declare + Pc : Pc_Type; + begin + Reg := Get_Expr_Reg (Stmt); + Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32h); + -- Note: this does not clobber a reg due to care in + -- insns. + Emit_Setcc_Reg + (Reg, Insns.Ekind_Signed_To_Cc (Kind)); + -- jne + Gen_2 (Opc_Jcc + 2#0101#, 0); + Pc := Get_Current_Pc; + Gen_Grp1_Insn (Opc2_Grp1_Cmp, Stmt, Sz_32l); + Emit_Setcc_Reg + (Reg, Insns.Ekind_Unsigned_To_Cc (Kind)); + Patch_8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc)); + return; + end; + end if; when Mode_F32 | Mode_F64 => if Abi.Flag_Sse2 then -- comisd %xmm, rm Start_Insn; + Init_Modrm_Expr (Get_Expr_Right (Stmt), Sz_32, + Get_Expr_Reg (Left)); Gen_SSE_D16_Opc (Op_Mode, 16#2f#); - Init_Rm_Expr (Get_Expr_Right (Stmt), Sz_32l); - Gen_Mod_Rm (To_Reg_Xmm (Get_Expr_Reg (Left)) * 8); + Gen_Mod_Rm_Reg; End_Insn; else -- fcomip st, st(1) Start_Insn; - Gen_B8 (2#11011_111#); - Gen_B8 (2#1111_0001#); + Gen_8 (2#11011_111#); + Gen_8 (2#1111_0001#); End_Insn; -- fstp st, st (0) Start_Insn; - Gen_B8 (2#11011_101#); - Gen_B8 (2#11_011_000#); + Gen_8 (2#11011_101#); + Gen_8 (2#11_011_000#); End_Insn; end if; when others => @@ -2121,21 +2519,36 @@ package body Ortho_Code.X86.Emits is -- Result is in eflags. pragma Assert (Get_Expr_Reg (Stmt) in Regs_Cc); end; - when OE_Const - | OE_Addrg => + when OE_Addrg => + pragma Assert (Mode = Abi.Mode_Ptr); + if Flags.M64 + and then not Insns.Is_External_Object (Get_Addr_Object (Stmt)) + then + -- Use RIP relative to load an address. + Emit_Lea (Stmt); + else + Emit_Load_Imm (Stmt, Sz_Ptr); + end if; + when OE_Const => 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_U32 + | Mode_I32 + | Mode_P32 => + Emit_Load_Imm (Stmt, Sz_32); when Mode_I64 - | Mode_U64 => - Emit_Load_Imm (Stmt, Sz_32l); - Emit_Load_Imm (Stmt, Sz_32h); + | Mode_U64 + | Mode_P64 => + if Flags.M64 then + Emit_Load_Imm (Stmt, Sz_64); + else + pragma Assert (Mode /= Mode_P64); + Emit_Load_Imm (Stmt, Sz_32l); + Emit_Load_Imm (Stmt, Sz_32h); + end if; when Mode_Fp => Emit_Load_Fp (Stmt, Mode); when others => @@ -2146,15 +2559,21 @@ package body Ortho_Code.X86.Emits is when Mode_U32 | Mode_I32 | Mode_P32 => - Emit_Load_Mem (Stmt, Sz_32l); + Emit_Load_Mem (Stmt, Sz_32); 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); + | Mode_I64 + | Mode_P64 => + if Flags.M64 then + Emit_Load_Mem (Stmt, Sz_64); + else + pragma Assert (Mode /= Mode_P64); + Emit_Load_Mem (Stmt, Sz_32l); + Emit_Load_Mem (Stmt, Sz_32h); + end if; when Mode_Fp => Emit_Load_Fp_Mem (Stmt, Mode); when others => @@ -2186,15 +2605,20 @@ package body Ortho_Code.X86.Emits is when Mode_U32 | Mode_I32 | Mode_P32 => - Emit_Store (Stmt, Sz_32l); + Emit_Store (Stmt, Sz_32); 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); + | Mode_I64 + | Mode_P64 => + if Flags.M64 then + Emit_Store (Stmt, Sz_64); + else + Emit_Store (Stmt, Sz_32l); + Emit_Store (Stmt, Sz_32h); + end if; when Mode_Fp => if Abi.Flag_Sse2 then Emit_Store_Xmm (Stmt, Mode); @@ -2231,11 +2655,16 @@ package body Ortho_Code.X86.Emits is when Mode_U32 | Mode_I32 | Mode_P32 => - Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32l); + Emit_Push (Get_Expr_Operand (Stmt), Sz_32); when Mode_U64 - | Mode_I64 => - Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32h); - Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32l); + | Mode_I64 + | Mode_P64 => + if Flags.M64 then + Emit_Push (Get_Expr_Operand (Stmt), Sz_64); + else + Emit_Push (Get_Expr_Operand (Stmt), Sz_32h); + Emit_Push (Get_Expr_Operand (Stmt), Sz_32l); + end if; when Mode_Fp => Emit_Push_Fp (Get_Expr_Operand (Stmt), Mode); when others => @@ -2256,10 +2685,10 @@ package body Ortho_Code.X86.Emits is Reg := Get_Expr_Reg (Stmt); case Mode is when Mode_B2 => - if Reg in Regs_R32 and then Op_Reg in Regs_Cc then + if Reg in Regs_R64 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 + and then Op_Reg in Regs_R64 then Emit_Tst (Op_Reg, Sz_8); else @@ -2267,22 +2696,26 @@ package body Ortho_Code.X86.Emits is end if; when Mode_U32 | Mode_I32 => - -- mov REG, OP - Start_Insn; - Gen_Insn_Sz (Opc_Mov_Reg_Rm, Sz_32l); - Gen_Rm (To_Reg32 (Reg, Sz_32l) * 8, Operand, Sz_32l); - End_Insn; + Emit_Move (Operand, Sz_32, Reg); + when Mode_U64 + | Mode_I64 + | Mode_P64 => + pragma Assert (Flags.M64); + Emit_Move (Operand, Sz_64, Reg); + when Mode_F64 + | Mode_F32 => + Emit_Move_Xmm (Operand, Mode, Reg); when others => Error_Emit ("emit_insn: move", Stmt); end case; end; when OE_Alloca => - pragma Assert (Mode = Mode_P32); + pragma Assert (Mode = Abi.Mode_Ptr); Gen_Alloca (Stmt); when OE_Set_Stack => - Emit_Load_Mem (Stmt, Sz_32l); + Emit_Load_Mem (Stmt, Sz_Ptr); when OE_Add | OE_Addrl => @@ -2291,6 +2724,11 @@ package body Ortho_Code.X86.Emits is | Mode_I32 | Mode_P32 => Emit_Lea (Stmt); + when Mode_U64 + | Mode_I64 + | Mode_P64 => + pragma Assert (Flags.M64); + Emit_Lea (Stmt); when others => Error_Emit ("emit_insn: oe_add", Stmt); end case; @@ -2304,11 +2742,16 @@ package body Ortho_Code.X86.Emits is when Mode_U32 | Mode_I32 | Mode_P32 => - Emit_Spill (Stmt, Sz_32l); + Emit_Spill (Stmt, Sz_32); when Mode_U64 - | Mode_I64 => - Emit_Spill (Stmt, Sz_32l); - Emit_Spill (Stmt, Sz_32h); + | Mode_I64 + | Mode_P64 => + if Flags.M64 then + Emit_Spill (Stmt, Sz_64); + else + Emit_Spill (Stmt, Sz_32l); + Emit_Spill (Stmt, Sz_32h); + end if; when Mode_F32 | Mode_F64 => Emit_Spill_Xmm (Stmt, Mode); @@ -2329,19 +2772,25 @@ package body Ortho_Code.X86.Emits is when Mode_U32 | Mode_I32 | Mode_P32 => - Emit_Load (Reg, Expr, Sz_32l); + Emit_Load (Reg, Expr, Sz_32); when Mode_U64 - | Mode_I64 => - Emit_Load (Reg, Expr, Sz_32l); - Emit_Load (Reg, Expr, Sz_32h); + | Mode_I64 + | Mode_P64 => + if Flags.M64 then + Emit_Load (Reg, Expr, Sz_64); + else + Emit_Load (Reg, Expr, Sz_32l); + Emit_Load (Reg, Expr, Sz_32h); + end if; when Mode_F32 | Mode_F64 => pragma Assert (Reg in Regs_Xmm); -- movsd - Init_Modrm_Mem (Expr, Sz_32l); Start_Insn; - Gen_SSE_Rep_Opc (Mode_F64, 16#10#); - Gen_Mod_Rm (To_Reg_Xmm (Reg) * 8); + Gen_SSE_Prefix (Mode_F64); + Init_Modrm_Mem (Expr, Sz_Fp, Reg); + Gen_SSE_Opc (Opc_Movsd_Xmm_M64); + Gen_Mod_Rm_Reg; End_Insn; when others => Error_Emit ("emit_insn: reload", Stmt); @@ -2365,21 +2814,33 @@ package body Ortho_Code.X86.Emits is end case; end Emit_Insn; - procedure Push_Reg_If_Used (Reg : Regs_R32) + function Get_Preserved_Regs return O_Reg_Array is + begin + if Flags.M64 then + return Preserved_Regs_64; + else + return Preserved_Regs_32; + end if; + end Get_Preserved_Regs; + + -- List of registers preserved accross calls. + Preserved_Regs : constant O_Reg_Array := Get_Preserved_Regs; + + procedure Push_Reg_If_Used (Reg : Regs_R64) is use Ortho_Code.X86.Insns; begin if Reg_Used (Reg) then - Gen_1 (Opc_Push_Reg + To_Reg32 (Reg, Sz_32l)); + Gen_Push_Pop_Reg (Opc_Push_Reg, Reg, Sz_Ptr); end if; end Push_Reg_If_Used; - procedure Pop_Reg_If_Used (Reg : Regs_R32) + procedure Pop_Reg_If_Used (Reg : Regs_R64) is use Ortho_Code.X86.Insns; begin if Reg_Used (Reg) then - Gen_1 (Opc_Pop_Reg + To_Reg32 (Reg, Sz_32l)); + Gen_Push_Pop_Reg (Opc_Pop_Reg, Reg, Sz_Ptr); end if; end Pop_Reg_If_Used; @@ -2393,6 +2854,7 @@ package body Ortho_Code.X86.Emits is Is_Global : Boolean; Frame_Size : Unsigned_32; Saved_Regs_Size : Unsigned_32; + Has_Fp_Inter : Boolean; begin -- Switch to .text section and align the function (to avoid the nested -- function trick and for performance). @@ -2412,52 +2874,110 @@ package body Ortho_Code.X86.Emits is 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; + -- Return address and saved frame pointer are preserved. + Saved_Regs_Size := 2; + for I in Preserved_Regs'Range loop + if Reg_Used (Preserved_Regs (I)) then + Saved_Regs_Size := Saved_Regs_Size + 1; + end if; + end loop; + if Flags.M64 then + Saved_Regs_Size := Saved_Regs_Size * 8; + else + Saved_Regs_Size := Saved_Regs_Size * 4; + end if; -- 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; + Frame_Size := Unsigned_32 (Subprg.Stack_Max) + 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; + -- The bytes for saved regs are already allocated. + Frame_Size := Frame_Size - Saved_Regs_Size; -- Emit prolog. - -- push %ebp - Gen_1 (Opc_Push_Reg + To_Reg32 (R_Bp)); - -- movl %esp, %ebp + -- push %ebp / push %rbp + Gen_Push_Pop_Reg (Opc_Push_Reg, R_Bp, Sz_Ptr); + -- movl %esp, %ebp / movl %rsp, %rbp Start_Insn; - Gen_B8 (Opc_Mov_Rm_Reg + 1); - Gen_B8 (2#11_100_101#); + Gen_Rex (16#48#); + Gen_8 (Opc_Mov_Rm_Reg + 1); + Gen_8 (2#11_100_101#); End_Insn; - -- subl XXX, %esp + + -- Save int registers. + Has_Fp_Inter := False; + if Flags.M64 then + declare + Inter : O_Dnode; + R : O_Reg; + begin + Inter := Get_Subprg_Interfaces (Subprg.D_Decl); + while Inter /= O_Dnode_Null loop + R := Get_Decl_Reg (Inter); + if R in Regs_R64 then + Gen_Push_Pop_Reg (Opc_Push_Reg, R, Sz_Ptr); + Frame_Size := Frame_Size - 8; + elsif R in Regs_Xmm then + Has_Fp_Inter := True; + else + pragma Assert (R = R_None); + null; + end if; + Inter := Get_Interface_Chain (Inter); + end loop; + end; + end if; + + -- subl XXX, %esp / subl XXX, %rsp if Frame_Size /= 0 then if not X86.Flags.Flag_Alloca_Call or else Frame_Size <= 4096 then - Init_Modrm_Reg (R_Sp, Sz_32l); - Gen_Insn_Grp1 (Opc2_Grp1_Sub, Sz_32l, Int32 (Frame_Size)); + Start_Insn; + Init_Modrm_Reg (R_Sp, Sz_Ptr); + Gen_Insn_Grp1 (Opc2_Grp1_Sub, Int32 (Frame_Size)); + End_Insn; else + pragma Assert (not Flags.M64); -- mov stack_size,%eax Start_Insn; - Gen_B8 (Opc_Movl_Imm_Reg + To_Reg32 (R_Ax)); - Gen_Le32 (Frame_Size); + Gen_8 (Opc_Movl_Imm_Reg + To_Reg32 (R_Ax)); + Gen_32 (Frame_Size); End_Insn; Gen_Call (Chkstk_Symbol); end if; end if; + if Flags.M64 and Has_Fp_Inter then + declare + Inter : O_Dnode; + R : O_Reg; + begin + Inter := Get_Subprg_Interfaces (Subprg.D_Decl); + while Inter /= O_Dnode_Null loop + R := Get_Decl_Reg (Inter); + if R in Regs_Xmm then + Start_Insn; + Gen_SSE_Prefix (Mode_F64); + Init_Modrm_Offset (R_Bp, Get_Local_Offset (Inter), Sz_Fp, R); + Gen_SSE_Opc (Opc_Movsd_M64_Xmm); + Gen_Mod_Rm_Reg; + End_Insn; + end if; + Inter := Get_Interface_Chain (Inter); + end loop; + end; + 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); + for I in Preserved_Regs'Range loop + Push_Reg_If_Used (Preserved_Regs (I)); + end loop; end Emit_Prologue; procedure Emit_Epilogue (Subprg : Subprogram_Data_Acc) @@ -2469,9 +2989,9 @@ package body Ortho_Code.X86.Emits is Mode : Mode_Type; begin -- Restore registers. - Pop_Reg_If_Used (R_Bx); - Pop_Reg_If_Used (R_Si); - Pop_Reg_If_Used (R_Di); + for I in reverse Preserved_Regs'Range loop + Pop_Reg_If_Used (Preserved_Regs (I)); + end loop; Decl := Subprg.D_Decl; if Get_Decl_Kind (Decl) = OD_Function then @@ -2481,30 +3001,32 @@ package body Ortho_Code.X86.Emits is | Mode_B2 => -- movzx %al,%eax Start_Insn; - Gen_B8 (Opc_0f); - Gen_B8 (Opc2_0f_Movzx); - Gen_B8 (2#11_000_000#); + Gen_8 (Opc_0f); + Gen_8 (Opc2_0f_Movzx); + Gen_8 (2#11_000_000#); End_Insn; when Mode_U32 | Mode_I32 | Mode_U64 | Mode_I64 - | Mode_P32 => + | Mode_P32 + | Mode_P64 => null; when Mode_F32 | Mode_F64 => - if Abi.Flag_Sse2 then + if Abi.Flag_Sse2 and not Flags.M64 then -- movsd %xmm0, slot(%ebp) - Init_Modrm_Offset - (R_Bp, -Int32 (Cur_Subprg.Target.Fp_Slot), Sz_32l); Start_Insn; - Gen_SSE_Rep_Opc (Mode, 16#11#); - Gen_Mod_Rm (2#00_000_000#); + Gen_SSE_Prefix (Mode); + Init_Modrm_Offset + (R_Bp, -Int32 (Cur_Subprg.Target.Fp_Slot), Sz_32); + Gen_SSE_Opc (Opc_Movsd_M64_Xmm); + Gen_Mod_Rm_Opc (2#00_000_000#); End_Insn; - -- fldl slot(%ebp) + -- fldl slot(%ebp) [keep same modrm parameters] Start_Insn; - Gen_B8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); - Gen_Mod_Rm (2#00_000_000#); + Gen_8 (2#11011_001# + Mode_Fp_To_Mf (Mode)); + Gen_Mod_Rm_Opc (2#00_000_000#); End_Insn; end if; when others => @@ -2556,7 +3078,7 @@ package body Ortho_Code.X86.Emits is Dtype : O_Tnode; begin Set_Current_Section (Sect_Bss); - Sym := Create_Symbol (Get_Decl_Ident (Decl)); + Sym := Create_Symbol (Get_Decl_Ident (Decl), False); Set_Decl_Info (Decl, To_Int32 (Uns32 (Sym))); Storage := Get_Decl_Storage (Decl); Dtype := Get_Decl_Type (Decl); @@ -2581,7 +3103,7 @@ package body Ortho_Code.X86.Emits is Sym : Symbol; begin Set_Current_Section (Sect_Rodata); - Sym := Create_Symbol (Get_Decl_Ident (Decl)); + Sym := Create_Symbol (Get_Decl_Ident (Decl), False); Set_Decl_Info (Decl, To_Int32 (Uns32 (Sym))); Set_Current_Section (Sect_Text); end Emit_Const_Decl; @@ -2603,23 +3125,24 @@ package body Ortho_Code.X86.Emits is when Mode_U8 | Mode_I8 | Mode_B2 => - Gen_B8 (Byte (L)); + Gen_8 (Byte (L)); when Mode_U32 | Mode_I32 | Mode_F32 | Mode_P32 => - Gen_Le32 (Unsigned_32 (L)); + Gen_32 (Unsigned_32 (L)); when Mode_F64 | Mode_I64 - | Mode_U64 => - Gen_Le32 (Unsigned_32 (L)); - Gen_Le32 (Unsigned_32 (H)); + | Mode_U64 + | Mode_P64 => + Gen_32 (Unsigned_32 (L)); + Gen_32 (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); + Gen_Abs (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)); @@ -2645,13 +3168,11 @@ package body Ortho_Code.X86.Emits is is use Decls; use Types; - Sym : Symbol; - Dtype : O_Tnode; + Sym : constant Symbol := Get_Decl_Symbol (Decl); + Dtype : constant O_Tnode := Get_Decl_Type (Decl); 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))); @@ -2665,7 +3186,11 @@ package body Ortho_Code.X86.Emits is use Ortho_Ident; use Ortho_Code.Flags; begin - Arch := Arch_X86; + if Flags.M64 then + Arch := Arch_X86_64; + else + Arch := Arch_X86; + end if; Create_Section (Sect_Text, ".text", Section_Exec + Section_Read); Create_Section (Sect_Rodata, ".rodata", Section_Read); @@ -2675,27 +3200,29 @@ package body Ortho_Code.X86.Emits is Set_Current_Section (Sect_Text); if Flag_Profile then - Mcount_Symbol := Create_Symbol (Get_Identifier ("mcount")); + Mcount_Symbol := Create_Symbol (Get_Identifier ("mcount"), True); end if; if X86.Flags.Flag_Alloca_Call then - Chkstk_Symbol := Create_Symbol (Get_Identifier ("___chkstk")); + Chkstk_Symbol := Create_Symbol (Get_Identifier ("___chkstk"), True); 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 not Flags.M64 then + Intrinsics_Symbol (Intrinsic_Mul_Ov_U64) := + Create_Symbol (Get_Identifier ("__muldi3"), True); + Intrinsics_Symbol (Intrinsic_Div_Ov_U64) := + Create_Symbol (Get_Identifier ("__mcode_div_ov_u64"), True); + Intrinsics_Symbol (Intrinsic_Mod_Ov_U64) := + Create_Symbol (Get_Identifier ("__mcode_mod_ov_u64"), True); + Intrinsics_Symbol (Intrinsic_Mul_Ov_I64) := + Create_Symbol (Get_Identifier ("__muldi3"), True); + Intrinsics_Symbol (Intrinsic_Div_Ov_I64) := + Create_Symbol (Get_Identifier ("__divdi3"), True); + Intrinsics_Symbol (Intrinsic_Mod_Ov_I64) := + Create_Symbol (Get_Identifier ("__mcode_mod_ov_i64"), True); + Intrinsics_Symbol (Intrinsic_Rem_Ov_I64) := + Create_Symbol (Get_Identifier ("__mcode_rem_ov_i64"), True); + end if; if Debug.Flag_Debug_Asm then Dump_Asm := True; diff --git a/src/ortho/mcode/ortho_code-x86-flags_linux.ads b/src/ortho/mcode/ortho_code-x86-flags_linux.ads index 30bc7f7..c60e0a7 100644 --- a/src/ortho/mcode/ortho_code-x86-flags_linux.ads +++ b/src/ortho/mcode/ortho_code-x86-flags_linux.ads @@ -28,4 +28,7 @@ package Ortho_Code.X86.Flags_Linux is -- Alignment for double (64 bit float). Mode_F64_Align : constant Natural := 2; + + -- 32 bits. + M64 : constant Boolean := False; end Ortho_Code.X86.Flags_Linux; diff --git a/src/ortho/mcode/ortho_code-x86-flags_linux64.ads b/src/ortho/mcode/ortho_code-x86-flags_linux64.ads new file mode 100644 index 0000000..000e6e0 --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-flags_linux64.ads @@ -0,0 +1,34 @@ +-- 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_Linux64 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 := 3; + + -- 32 bits. + M64 : constant Boolean := True; +end Ortho_Code.X86.Flags_Linux64; diff --git a/src/ortho/mcode/ortho_code-x86-flags_macosx.ads b/src/ortho/mcode/ortho_code-x86-flags_macosx.ads index a330852..8966e53 100644 --- a/src/ortho/mcode/ortho_code-x86-flags_macosx.ads +++ b/src/ortho/mcode/ortho_code-x86-flags_macosx.ads @@ -28,4 +28,7 @@ package Ortho_Code.X86.Flags_Macosx is -- Alignment for double (64 bit float). Mode_F64_Align : constant Natural := 2; + + -- 32 bits. + M64 : constant Boolean := False; end Ortho_Code.X86.Flags_Macosx; diff --git a/src/ortho/mcode/ortho_code-x86-flags_macosx64.ads b/src/ortho/mcode/ortho_code-x86-flags_macosx64.ads new file mode 100644 index 0000000..caf4e2a --- /dev/null +++ b/src/ortho/mcode/ortho_code-x86-flags_macosx64.ads @@ -0,0 +1,34 @@ +-- X86-64 ABI flags for MacOS X. +-- Copyright (C) 2006 - 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Interfaces; use Interfaces; + +package Ortho_Code.X86.Flags_Macosx64 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 := 3; + + -- 64 bits. + M64 : constant Boolean := True; +end Ortho_Code.X86.Flags_Macosx64; diff --git a/src/ortho/mcode/ortho_code-x86-flags_windows.ads b/src/ortho/mcode/ortho_code-x86-flags_windows.ads index 3296aaf..dfe6e67 100644 --- a/src/ortho/mcode/ortho_code-x86-flags_windows.ads +++ b/src/ortho/mcode/ortho_code-x86-flags_windows.ads @@ -28,4 +28,7 @@ package Ortho_Code.X86.Flags_Windows is -- Alignment for double (64 bit float). Mode_F64_Align : constant Natural := 3; + + -- 32 bits. + M64 : constant Boolean := False; 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 index e975455..ba6919e 100644 --- a/src/ortho/mcode/ortho_code-x86-insns.adb +++ b/src/ortho/mcode/ortho_code-x86-insns.adb @@ -1,5 +1,5 @@ -- Mcode back-end for ortho - mcode to X86 instructions. --- Copyright (C) 2006 Tristan Gingold +-- Copyright (C) 2006 - 2015 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free @@ -82,6 +82,12 @@ package body Ortho_Code.X86.Insns is end if; end Link_Stmt; + function Is_External_Object (Obj : O_Dnode) return Boolean is + begin + return Flags.M64 + and then Get_Decl_Storage (Obj) = O_Storage_External; + end Is_External_Object; + -- Return the 'any register' constraint for mode MODE. function Get_Reg_Any (Mode : Mode_Type) return O_Reg is begin @@ -95,8 +101,13 @@ package body Ortho_Code.X86.Insns is | Mode_B2 => return R_Any8; when Mode_U64 - | Mode_I64 => - return R_Any64; + | Mode_I64 + | Mode_P64 => + if Flags.M64 then + return R_Any64; + else + return R_AnyPair; + end if; when Mode_F32 | Mode_F64 => if Abi.Flag_Sse2 then @@ -104,8 +115,7 @@ package body Ortho_Code.X86.Insns is else return R_St0; end if; - when Mode_P64 - | Mode_X1 + when Mode_X1 | Mode_Nil | Mode_Blk => raise Program_Error; @@ -235,7 +245,10 @@ package body Ortho_Code.X86.Insns is -- 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 + function Reverse_Cc (Cc : O_Reg) return O_Reg + is + -- Only used when not sse. + pragma Assert (not Abi.Flag_Sse2); begin case Cc is when R_Ult => @@ -273,15 +286,22 @@ package body Ortho_Code.X86.Insns is | Mode_B2 => return R_Ax; when Mode_U64 - | Mode_I64 => - return R_Edx_Eax; + | Mode_I64 + | Mode_P64 => + if Flags.M64 then + return R_Ax; + else + return R_Edx_Eax; + end if; when Mode_F32 | Mode_F64 => if Abi.Flag_Sse2 then -- Strictly speaking, this is not true as ST0 is used on x86. -- The conversion is done by emits (this requires a stack -- slot). - Need_Fp_Conv_Slot := True; + if not Flags.M64 then + Need_Fp_Conv_Slot := True; + end if; return R_Xmm0; else return R_St0; @@ -289,8 +309,7 @@ package body Ortho_Code.X86.Insns is when Mode_Nil => return R_None; when Mode_X1 - | Mode_Blk - | Mode_P64 => + | Mode_Blk => raise Program_Error; end case; end Get_Return_Register; @@ -355,29 +374,33 @@ package body Ortho_Code.X86.Insns is -- All callee-saved registers marked 'used' must be saved in the prolog. Used : Boolean; end record; + pragma Suppress_Initialization (Reg_Info_Type); -- Not needed. 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); + type RegGp_Info_Array is array (Regs_R64) of Reg_Info_Type; + pragma Suppress_Initialization (RegGp_Info_Array); -- Not needed. + Regs : RegGp_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; + pragma Suppress_Initialization (RegFp_Info_Array); -- Not needed. Fp_Top : Fp_Stack_Type := 0; Fp_Regs : RegFp_Info_Array; type Reg_Xmm_Info_Array is array (Regs_Xmm) of Reg_Info_Type; + pragma Suppress_Initialization (Reg_Xmm_Info_Array); -- Not needed. Xmm_Regs : Reg_Xmm_Info_Array := (others => Init_Reg_Info); - function Reg_Used (Reg : Regs_R32) return Boolean is + function Reg_Used (Reg : Regs_R64) return Boolean is begin return Regs (Reg).Used; end Reg_Used; - procedure Dump_Reg32_Info (Reg : Regs_R32) + procedure Dump_Reg32_Info (Reg : Regs_R64) is use Ada.Text_IO; use Ortho_Code.Debug.Int32_IO; @@ -409,12 +432,19 @@ package body Ortho_Code.X86.Insns is 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; + if Flags.M64 then + for I in Regs_R8_R15 loop + Dump_Reg32_Info (I); + end loop; + end if; + if not Abi.Flag_Sse2 then + 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 if; end Dump_Regs; pragma Unreferenced (Dump_Regs); @@ -439,14 +469,15 @@ package body Ortho_Code.X86.Insns is -- Free_XX -- Mark a register as unused. - procedure Free_R32 (Reg : O_Reg) is + procedure Free_Gp (Reg : O_Reg) is begin pragma Assert (Regs (Reg).Num /= O_Free); Regs (Reg).Num := O_Free; - end Free_R32; + end Free_Gp; procedure Free_Fp is begin + pragma Assert (not Abi.Flag_Sse2); pragma Assert (Fp_Regs (Fp_Top).Num /= O_Free); Fp_Regs (Fp_Top).Num := O_Free; Fp_Top := Fp_Top + 1; @@ -511,7 +542,7 @@ package body Ortho_Code.X86.Insns is return Reg_Orig; end Insert_Spill; - procedure Spill_R32 (Reg : Regs_R32) + procedure Spill_Gp (Reg : Regs_R64) is Reg_Orig : O_Reg; begin @@ -522,36 +553,38 @@ package body Ortho_Code.X86.Insns is -- Free the register. case Reg_Orig is - when Regs_R32 => - pragma Assert (Reg_Orig = Reg); - Free_R32 (Reg); when Regs_R64 => + pragma Assert (Reg_Orig = Reg); + Free_Gp (Reg); + when Regs_Pair => + pragma Assert (not Flags.M64); -- The pair was spilled, so the pair is free. - Free_R32 (Get_R64_High (Reg_Orig)); - Free_R32 (Get_R64_Low (Reg_Orig)); + Free_Gp (Get_Pair_High (Reg_Orig)); + Free_Gp (Get_Pair_Low (Reg_Orig)); when others => raise Program_Error; end case; - end Spill_R32; + end Spill_Gp; - procedure Alloc_R32 (Reg : Regs_R32; Stmt : O_Enode; Num : O_Inum) is + procedure Alloc_Gp (Reg : Regs_R64; Stmt : O_Enode; Num : O_Inum) is begin if Regs (Reg).Num /= O_Free then - Spill_R32 (Reg); + Spill_Gp (Reg); end if; Regs (Reg) := (Num => Num, Stmt => Stmt, Used => True); - end Alloc_R32; + end Alloc_Gp; - procedure Clobber_R32 (Reg : O_Reg) is + procedure Clobber_Gp (Reg : O_Reg) is begin if Regs (Reg).Num /= O_Free then - Spill_R32 (Reg); + Spill_Gp (Reg); end if; - end Clobber_R32; + end Clobber_Gp; - procedure Alloc_Fp (Stmt : O_Enode) - is + procedure Alloc_Fp (Stmt : O_Enode) is begin + pragma Assert (not Abi.Flag_Sse2); + Fp_Top := Fp_Top - 1; if Fp_Regs (Fp_Top).Stmt /= O_Enode_Null then @@ -561,19 +594,20 @@ package body Ortho_Code.X86.Insns is Fp_Regs (Fp_Top).Stmt := Stmt; end Alloc_Fp; - procedure Alloc_R64 (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) + procedure Alloc_Pair (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) is - Rl : constant O_Reg := Get_R64_Low (Reg); - Rh : constant O_Reg := Get_R64_High (Reg); + pragma Assert (not Flags.M64); + Rl : constant O_Reg := Get_Pair_Low (Reg); + Rh : constant O_Reg := Get_Pair_High (Reg); begin if Regs (Rl).Num /= O_Free or Regs (Rh).Num /= O_Free then - Spill_R32 (Rl); + Spill_Gp (Rl); end if; Regs (Rh) := (Num => Num, Stmt => Stmt, Used => True); Regs (Rl) := (Num => Num, Stmt => Stmt, Used => True); - end Alloc_R64; + end Alloc_Pair; procedure Alloc_Cc (Stmt : O_Enode; Num : O_Inum) is begin @@ -612,29 +646,43 @@ package body Ortho_Code.X86.Insns is function Alloc_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) return O_Reg is + Last_Reg : O_Reg; 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); + Alloc_Gp (Reg, Stmt, Num); + return Reg; + when Regs_Pair => + pragma Assert (not Flags.M64); + Alloc_Pair (Reg, Stmt, Num); return Reg; when R_St0 => + pragma Assert (not Abi.Flag_Sse2); Alloc_Fp (Stmt); return Reg; when Regs_Xmm => Alloc_Xmm (Reg, Stmt, Num); return Reg; - when R_Any32 => + when R_Any8 + | R_Any32 + | R_Any64 => + if Flags.M64 then + Last_Reg := R_R15; + else + if Reg = R_Any8 then + Last_Reg := R_Bx; + else + Last_Reg := R_Di; + end if; + end if; Best_Num := O_Inum'Last; Best_Reg := R_None; - for I in Regs_R32 loop + for I in R_Ax .. Last_Reg loop if I not in R_Sp .. R_Bp then if Regs (I).Num = O_Free then - Alloc_R32 (I, Stmt, Num); + Alloc_Gp (I, Stmt, Num); return I; elsif Regs (I).Num <= Best_Num then Best_Reg := I; @@ -642,35 +690,22 @@ package body Ortho_Code.X86.Insns is end if; end if; end loop; - Alloc_R32 (Best_Reg, Stmt, Num); + Alloc_Gp (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 => + when R_AnyPair => + pragma Assert (not Flags.M64); 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); + for I in Regs_Pair loop + Rh := Get_Pair_High (I); + Rl := Get_Pair_Low (I); if Regs (Rh).Num = O_Free and then Regs (Rl).Num = O_Free then - Alloc_R64 (I, Stmt, Num); + Alloc_Pair (I, Stmt, Num); return I; elsif Regs (Rh).Num <= Best_Num and Regs (Rl).Num <= Best_Num @@ -680,7 +715,7 @@ package body Ortho_Code.X86.Insns is Regs (Rl).Num); end if; end loop; - Alloc_R64 (Best_Reg, Stmt, Num); + Alloc_Pair (Best_Reg, Stmt, Num); return Best_Reg; end; when R_Any_Xmm => @@ -735,11 +770,12 @@ package body Ortho_Code.X86.Insns is | R_Rm => -- Some instructions can do the reload by themself. return Spill; - when Regs_R32 - | R_Any32 - | Regs_R64 + when Regs_R64 | R_Any64 + | R_Any32 | R_Any8 + | R_AnyPair + | Regs_Pair | Regs_Xmm | R_Any_Xmm => return Gen_Reload (Spill, Dest, Num); @@ -750,29 +786,36 @@ package body Ortho_Code.X86.Insns is when others => Error_Reg ("reload: unhandled dest in spill", Expr, Dest); end case; - when Regs_R32 => + when Regs_R64 => case Dest is when R_Irm | R_Rm | R_Ir + | R_Any64 | R_Any32 | R_Any8 | R_Sib => return Expr; - when Regs_R32 => + when Regs_R64 => if Dest = Reg then return Expr; end if; - Free_R32 (Reg); + if Reg /= R_Bp then + -- Never free BP as it is not allocated (fixed register). + -- BP can be referenced by OE_Get_Frame. + Free_Gp (Reg); + end if; Spill := Insert_Move (Expr, Dest); - Alloc_R32 (Dest, Spill, Num); + Alloc_Gp (Dest, Spill, Num); return Spill; when others => Error_Reg ("reload: unhandled dest in R32", Expr, Dest); end case; - when Regs_R64 => + when Regs_Pair => + pragma Assert (not Flags.M64); return Expr; when R_St0 => + pragma Assert (not Abi.Flag_Sse2); return Expr; when Regs_Xmm => return Expr; @@ -801,6 +844,8 @@ package body Ortho_Code.X86.Insns is Set_Addrl_Frame (Expr, Reload (Spill, R_Any32, Num)); end if; return Expr; + when OE_Addrg => + return Expr; when others => Error_Reg ("reload: unhandle expr in b_off", Expr, Dest); end case; @@ -817,25 +862,27 @@ package body Ortho_Code.X86.Insns is procedure Renum_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) is begin case Reg is - when Regs_R32 => + when Regs_R64 => Regs (Reg).Num := Num; Regs (Reg).Stmt := Stmt; when Regs_Cc => Reg_Cc.Num := Num; Reg_Cc.Stmt := Stmt; when R_St0 => + pragma Assert (not Abi.Flag_Sse2); null; when Regs_Xmm => Xmm_Regs (Reg).Num := Num; Xmm_Regs (Reg).Stmt := Stmt; - when Regs_R64 => + when Regs_Pair => + pragma Assert (not Flags.M64); declare L, H : O_Reg; begin - L := Get_R64_Low (Reg); + L := Get_Pair_Low (Reg); Regs (L).Num := Num; Regs (L).Stmt := Stmt; - H := Get_R64_High (Reg); + H := Get_Pair_High (Reg); Regs (H).Num := Num; Regs (H).Stmt := Stmt; end; @@ -854,18 +901,21 @@ package body Ortho_Code.X86.Insns is | R_Cx | R_Dx | R_Si - | R_Di => - Free_R32 (R); + | R_Di + | Regs_R8_R15 => + Free_Gp (R); when R_Sp | R_Bp => null; when R_St0 => + pragma Assert (not Abi.Flag_Sse2); Free_Fp; when Regs_Xmm => Free_Xmm (R); - when Regs_R64 => - Free_R32 (Get_R64_High (R)); - Free_R32 (Get_R64_Low (R)); + when Regs_Pair => + pragma Assert (not Flags.M64); + Free_Gp (Get_Pair_High (R)); + Free_Gp (Get_Pair_Low (R)); when R_Mem => if Get_Expr_Kind (Insn) = OE_Indir then Free_Insn_Regs (Get_Expr_Operand (Insn)); @@ -884,6 +934,9 @@ package body Ortho_Code.X86.Insns is if Get_Addrl_Frame (Insn) /= O_Enode_Null then Free_Insn_Regs (Get_Addrl_Frame (Insn)); end if; + when OE_Addrg => + -- RIP-relative, no reg to free. + null; when others => raise Program_Error; end case; @@ -900,6 +953,7 @@ package body Ortho_Code.X86.Insns is procedure Insert_Reg (Mode : Mode_Type) is + pragma Assert (not Flags.M64); N : O_Enode; Num : O_Inum; begin @@ -911,24 +965,54 @@ package body Ortho_Code.X86.Insns is Free_Insn_Regs (N); end Insert_Reg; - procedure Insert_Arg (Expr : O_Enode) + -- 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 - N : O_Enode; + Left : O_Enode; + Num : O_Inum; 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; + if not Flags.M64 then + -- Need a temporary to work. Always use FPU. + Need_Fp_Conv_Slot := True; + end if; + Num := Get_Insn_Num; + Left := Get_Expr_Operand (Stmt); + Left := Gen_Insn (Left, Get_Reg_Any (Left), Num); + Free_Insn_Regs (Left); + Set_Expr_Operand (Stmt, Left); + case Reg is + when R_Any32 + | Regs_R64 + | R_Any64 + | Regs_Pair + | R_AnyPair => + 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; + end Gen_Conv_From_Fp_Insn; -- Mark all registers that aren't preserved by a call as clobbered, so that -- they are saved. - procedure Clobber_Caller_Saved_Registers is + procedure Clobber_Caller_Saved_Registers_32 + is + pragma Assert (not Flags.M64); begin - Clobber_R32 (R_Ax); - Clobber_R32 (R_Dx); - Clobber_R32 (R_Cx); + Clobber_Gp (R_Ax); + Clobber_Gp (R_Dx); + Clobber_Gp (R_Cx); -- FIXME: fp regs. if Abi.Flag_Sse2 then @@ -936,11 +1020,62 @@ package body Ortho_Code.X86.Insns is Clobber_Xmm (R); end loop; end if; - end Clobber_Caller_Saved_Registers; + end Clobber_Caller_Saved_Registers_32; + procedure Clobber_Caller_Saved_Registers_64 + (First_Arg : O_Enode; Subprg : O_Dnode; Num : O_Inum) + is + pragma Assert (Flags.M64); + Inter : O_Dnode; + Arg : O_Enode; + Expr : O_Enode; + Reg : O_Reg; + T : O_Enode; + begin + -- Reload all parameters passed in registers and free regs. + Inter := Get_Subprg_Interfaces (Subprg); + Arg := First_Arg; + while Inter /= O_Dnode_Null loop + Reg := Get_Decl_Reg (Inter); + if Reg /= R_None then + Expr := Get_Expr_Operand (Arg); + T := Reload (Expr, Reg, Num); + Free_Insn_Regs (T); + end if; + Inter := Get_Interface_Chain (Inter); + Arg := Get_Arg_Link (Arg); + end loop; + + -- Mark caller saved registers as clobbered. + for R in R_Ax .. R_Dx loop + Clobber_Gp (R); + end loop; + for R in R_Si .. R_R11 loop + Clobber_Gp (R); + end loop; + for R in Regs_Xmm loop + Clobber_Xmm (R); + end loop; + end Clobber_Caller_Saved_Registers_64; + + -- Insert an argument for an intrinsic call. + procedure Insert_Arg (Expr : O_Enode) + is + pragma Assert (not Flags.M64); + 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; + + -- Insert a call to an instrinsic (a libgcc helper). function Insert_Intrinsic (Stmt : O_Enode; Reg : O_Reg; Num : O_Inum) return O_Enode is + pragma Assert (not Flags.M64); Mode : constant Mode_Type := Get_Expr_Mode (Stmt); N : O_Enode; Op : Int32; @@ -988,7 +1123,7 @@ package body Ortho_Code.X86.Insns is end case; -- Save caller-saved registers. - Clobber_Caller_Saved_Registers; + Clobber_Caller_Saved_Registers_32; N := New_Enode (OE_Intrinsic, Mode, O_Tnode_Null, O_Enode (Op), O_Enode_Null); @@ -997,42 +1132,6 @@ package body Ortho_Code.X86.Insns is 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 - Left : O_Enode; - Num : O_Inum; - begin - -- Need a temporary to work. Always use FPU. - Need_Fp_Conv_Slot := True; - Num := Get_Insn_Num; - Left := Get_Expr_Operand (Stmt); - Left := Gen_Insn (Left, Get_Reg_Any (Get_Expr_Mode (Left)), 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; - end Gen_Conv_From_Fp_Insn; - procedure Gen_Stack_Adjust (Off : Int32) is use Ortho_Code.Abi; @@ -1054,19 +1153,68 @@ package body Ortho_Code.X86.Insns is end if; end Gen_Stack_Adjust; + procedure Gen_Call_Arg (Arg : O_Enode; Inter : O_Dnode; Pnum : O_Inum) + is + begin + if Arg = O_Enode_Null then + -- End of args. + pragma Assert (Inter = O_Dnode_Null); + return; + else + -- Recurse on next argument, so the first argument is pushed + -- the last one. + pragma Assert (Inter /= O_Dnode_Null); + Gen_Call_Arg (Get_Arg_Link (Arg), Get_Interface_Chain (Inter), Pnum); + end if; + + declare + Inter_Reg : constant O_Reg := Get_Decl_Reg (Inter); + Reg : O_Reg; + Expr : O_Enode; + begin + Expr := Get_Expr_Operand (Arg); + if Inter_Reg = R_None then + -- On the stack. + case Get_Expr_Mode (Expr) is + when Mode_F32 .. Mode_F64 => + -- fstp instruction. + if Abi.Flag_Sse2 then + Reg := R_Any_Xmm; + else + Reg := R_St0; + end if; + when others => + -- Push instruction. + Reg := R_Irm; + end case; + else + Reg := Inter_Reg; + end if; + Expr := Gen_Insn (Expr, Reg, Pnum); + Set_Expr_Operand (Arg, Expr); + if Inter_Reg = R_None then + -- Link the OE_Arg code (it will be translated as a push). + Link_Stmt (Arg); + -- Use Mode_Ptr for a 32 or 64 bit word. + Push_Offset := Push_Offset + + Do_Align (Get_Mode_Size (Get_Expr_Mode (Expr)), Abi.Mode_Ptr); + Free_Insn_Regs (Expr); + end if; + end; + end Gen_Call_Arg; + function Gen_Call (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum) return O_Enode is use Interfaces; Subprg : constant O_Dnode := Get_Call_Subprg (Stmt); Push_Size : constant Uns32 := Uns32 (Get_Subprg_Stack (Subprg)); - Left : O_Enode; Reg_Res : O_Reg; Pad : Uns32; Res_Stmt : O_Enode; begin -- Emit Setup_Frame (to align stack). - -- Pad the stack if necessary. + -- Pad the stack if necessary (this may be a nested call). Pad := (Push_Size + Push_Offset) and Uns32 (Flags.Stack_Boundary - 1); if Pad /= 0 then Pad := Uns32 (Flags.Stack_Boundary) - Pad; @@ -1076,13 +1224,14 @@ package body Ortho_Code.X86.Insns is 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; + Gen_Call_Arg (Get_Arg_Link (Stmt), Get_Subprg_Interfaces (Subprg), Pnum); -- Clobber registers. - Clobber_Caller_Saved_Registers; + if Flags.M64 then + Clobber_Caller_Saved_Registers_64 (Get_Arg_Link (Stmt), Subprg, Pnum); + else + Clobber_Caller_Saved_Registers_32; + end if; -- Add the call. Reg_Res := Get_Return_Register (Get_Expr_Mode (Stmt)); @@ -1092,26 +1241,37 @@ package body Ortho_Code.X86.Insns is if Push_Size + Pad /= 0 then Gen_Stack_Adjust (-Int32 (Push_Size + Pad)); - end if; - -- The stack has been restored (just after the call). - Push_Offset := Push_Offset - (Push_Size + Pad); + -- The stack has been restored (just after the call). + Push_Offset := Push_Offset - (Push_Size + Pad); + end if; case Reg is when R_Any32 | R_Any64 + | R_AnyPair | R_Any8 | R_Any_Xmm | R_Irm | R_Rm | R_Ir | R_Sib - | R_Ax | R_St0 - | R_Edx_Eax - | R_Xmm0 => + | R_Edx_Eax => Reg_Res := Alloc_Reg (Reg_Res, Res_Stmt, Pnum); return Res_Stmt; + when Regs_R64 => + if Reg /= Reg_Res then + Res_Stmt := Insert_Move (Res_Stmt, Reg); + end if; + Alloc_Gp (Reg, Res_Stmt, Pnum); + return Res_Stmt; + when Regs_Xmm => + if Reg /= Reg_Res then + Res_Stmt := Insert_Move (Res_Stmt, Reg); + end if; + Alloc_Xmm (Reg, Res_Stmt, Pnum); + return Res_Stmt; when R_Any_Cc => -- Move to register. -- (use the 'test' instruction). @@ -1145,8 +1305,9 @@ package body Ortho_Code.X86.Insns is when OE_Addrl => Right := Get_Addrl_Frame (Stmt); if Right /= O_Enode_Null then + -- Outer frame. Num := Get_Insn_Num; - Right := Gen_Insn (Right, R_Any32, Num); + Right := Gen_Insn (Right, R_Any64, Num); Set_Addrl_Frame (Stmt, Right); else Num := O_Free; @@ -1156,31 +1317,53 @@ package body Ortho_Code.X86.Insns is Set_Expr_Reg (Stmt, R_B_Off); return Stmt; when R_Irm - | R_Ir => + | R_Ir + | Regs_R64 => if Right /= O_Enode_Null then Free_Insn_Regs (Right); end if; - Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum)); + if Reg in Regs_R64 then + Reg1 := Reg; + else + Reg1 := R_Any64; + end if; + Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, 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); + if Flags.M64 then + -- Use RIP-Relative addressing. + if Reg = R_Sib + and then not Is_External_Object (Get_Addr_Object (Stmt)) + then + Set_Expr_Reg (Stmt, R_Sib); + else + if Reg in Regs_R64 then + Reg1 := Reg; + else + Reg1 := R_Any64; + end if; + Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, Stmt, Pnum)); Link_Stmt (Stmt); - return Stmt; - when others => - Error_Gen_Insn (Stmt, Reg); - end case; + end if; + else + case Reg is + when R_Sib + | R_Irm + | R_Ir => + Set_Expr_Reg (Stmt, R_Imm); + 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 if; + return Stmt; when OE_Indir => Left := Get_Expr_Operand (Stmt); case Reg is @@ -1195,7 +1378,8 @@ package body Ortho_Code.X86.Insns is Num := Get_Insn_Num; Left := Gen_Insn (Left, R_Sib, Num); Reg1 := Get_Reg_Any (Stmt); - if Reg1 = R_Any64 then + if Reg1 = R_AnyPair then + pragma Assert (not Flags.M64); Reg1 := Alloc_Reg (Reg1, Stmt, Pnum); Free_Insn_Regs (Left); else @@ -1205,7 +1389,8 @@ package body Ortho_Code.X86.Insns is Set_Expr_Reg (Stmt, Reg1); Set_Expr_Operand (Stmt, Left); Link_Stmt (Stmt); - when Regs_R32 + when Regs_R64 + | R_Any64 | R_Any32 | R_Any8 | R_Any_Xmm @@ -1217,8 +1402,9 @@ package body Ortho_Code.X86.Insns is Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); Set_Expr_Operand (Stmt, Left); Link_Stmt (Stmt); - when Regs_R64 - | R_Any64 => + when Regs_Pair + | R_AnyPair => + pragma Assert (not Flags.M64); -- Avoid overwritting: -- Eg: axdx = indir (ax) -- axdx = indir (ax+dx) @@ -1247,6 +1433,12 @@ package body Ortho_Code.X86.Insns is return Gen_Insn (Get_Expr_Operand (Stmt), Reg, Pnum); when OE_Const => + -- 2.2.1.3 Displacement + -- They remain 8 bits or 32 bits and are sign-extended to 64 bits. + -- + -- 2.2.1.5 Immediates + -- [..] the processor sign-extends all immediates to 64 bits prior + -- their use. case Get_Expr_Mode (Stmt) is when Mode_U8 .. Mode_U32 | Mode_I8 .. Mode_I32 @@ -1256,7 +1448,7 @@ package body Ortho_Code.X86.Insns is when R_Imm | Regs_Imm32 => Set_Expr_Reg (Stmt, R_Imm); - when Regs_R32 + when Regs_R64 | R_Any32 | R_Any8 => Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); @@ -1298,21 +1490,56 @@ package body Ortho_Code.X86.Insns is Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, Stmt, Num)); Link_Stmt (Stmt); 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)); + | Mode_I64 + | Mode_P64 => + if Flags.M64 then + if Is_Expr_S32 (Stmt) then + -- Fit in a disp, can use SIB. + case Reg is + when R_Irm + | R_Ir => + Reg1 := R_Imm; + when R_Mem => + Reg1 := R_Mem; + when Regs_R64 => + Alloc_Gp (Reg, Stmt, Pnum); + Reg1 := Reg; + when R_Any64 + | R_Rm => + Reg1 := Alloc_Reg (R_Any64, Stmt, Pnum); + when others => + raise Program_Error; + end case; + Set_Expr_Reg (Stmt, Reg1); + if Reg1 in Regs_R64 then + Link_Stmt (Stmt); + end if; + else + -- Need a register to load the constants. + if Reg in Regs_R64 then + Reg1 := Reg; + else + Reg1 := R_Any64; + end if; + Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, Stmt, Pnum)); Link_Stmt (Stmt); - when others => - raise Program_Error; - end case; + end if; + else + 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_Pair + | R_AnyPair => + Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum)); + Link_Stmt (Stmt); + when others => + raise Program_Error; + end case; + end if; when others => raise Program_Error; end case; @@ -1385,42 +1612,44 @@ package body Ortho_Code.X86.Insns is Reg_Res := Reverse_Cc (Reg_Res); end if; 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; + -- I64 is a little bit special on x86-32. + if not Flags.M64 then + Reg_Res := Get_Pair_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 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); + 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; + 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; + end if; when others => null; end case; @@ -1464,7 +1693,8 @@ package body Ortho_Code.X86.Insns is -- Results can be: Reg, R_B_Off, R_Sib, R_Imm, R_B_I case R_L is when R_Any32 - | Regs_R32 => + | R_Any64 + | Regs_R64 => case R_R is when R_Imm => Set_Expr_Reg (Stmt, R_B_Off); @@ -1473,7 +1703,8 @@ package body Ortho_Code.X86.Insns is | R_I_Off => Set_Expr_Reg (Stmt, R_Sib); when R_Any32 - | Regs_R32 => + | R_Any64 + | Regs_R64 => Set_Expr_Reg (Stmt, R_B_I); when others => Error_Gen_Insn (Stmt, R_R); @@ -1483,7 +1714,8 @@ package body Ortho_Code.X86.Insns is when R_Imm => Set_Expr_Reg (Stmt, R_Imm); when R_Any32 - | Regs_R32 + | R_Any64 + | Regs_R64 | R_B_Off => Set_Expr_Reg (Stmt, R_B_Off); when R_I @@ -1497,7 +1729,8 @@ package body Ortho_Code.X86.Insns is when R_Imm => Set_Expr_Reg (Stmt, R_B_Off); when R_Any32 - | Regs_R32 + | R_Any64 + | Regs_R64 | R_I => Set_Expr_Reg (Stmt, R_Sib); when others => @@ -1508,7 +1741,8 @@ package body Ortho_Code.X86.Insns is when R_Imm => Set_Expr_Reg (Stmt, R_I_Off); when R_Any32 - | Regs_R32 => + | R_Any64 + | Regs_R64 => Set_Expr_Reg (Stmt, R_Sib); when others => Error_Gen_Insn (Stmt, R_R); @@ -1516,7 +1750,7 @@ package body Ortho_Code.X86.Insns is when R_I => case R_R is when R_Imm - | Regs_R32 + | Regs_R64 | R_B_Off => Set_Expr_Reg (Stmt, R_Sib); when others => @@ -1533,7 +1767,8 @@ package body Ortho_Code.X86.Insns is Link_Stmt (Left); case R_R is when R_Any32 - | Regs_R32 + | R_Any64 + | Regs_R64 | R_I => Set_Expr_Reg (Stmt, R_B_I); when others => @@ -1548,17 +1783,16 @@ package body Ortho_Code.X86.Insns is when R_Sib => null; when R_Ir - | R_Irm => + | R_Irm + | R_Any32 + | R_Any64 + | Regs_R64 => 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); + Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum)); 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; @@ -1576,7 +1810,7 @@ package body Ortho_Code.X86.Insns is Free_Insn_Regs (Left); Free_Insn_Regs (Right); - Clobber_R32 (R_Dx); + Clobber_Gp (R_Dx); Set_Expr_Reg (Stmt, Alloc_Reg (R_Ax, Stmt, Pnum)); case Reg is when R_Sib @@ -1646,11 +1880,12 @@ package body Ortho_Code.X86.Insns is Alloc_Cc (Stmt, Num); Free_Insn_Regs (Left); when R_Any32 - | Regs_R32 - | R_Any8 | R_Any64 - | R_Any_Xmm | Regs_R64 + | R_Any8 + | R_AnyPair + | R_Any_Xmm + | Regs_Pair | Regs_Fp | Regs_Xmm => Left := Gen_Insn (Left, Reg, Num); @@ -1679,9 +1914,22 @@ package body Ortho_Code.X86.Insns is Num := Get_Insn_Num; Left := Get_Expr_Left (Stmt); Right := Get_Expr_Right (Stmt); + + if not Flags.M64 + and (Mode = Mode_I64 or Mode = Mode_U64) + then + -- Call libgcc helper on x86-32. + -- 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); + end if; + case Mode is when Mode_I32 | Mode_U32 + | Mode_I64 + | Mode_U64 | Mode_I16 | Mode_U16 => Left := Gen_Insn (Left, R_Ax, Num); @@ -1702,24 +1950,18 @@ package body Ortho_Code.X86.Insns is Free_Insn_Regs (Left); Free_Insn_Regs (Right); if Reg_Res /= R_Nil then - Free_R32 (Reg_Res); + Free_Gp (Reg_Res); end if; if Kind = OE_Div_Ov or Kind = OE_Mul_Ov then Reg_Res := R_Ax; - Clobber_R32 (R_Dx); + Clobber_Gp (R_Dx); else Reg_Res := R_Dx; - Clobber_R32 (R_Ax); + Clobber_Gp (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 => if Abi.Flag_Sse2 then @@ -1754,11 +1996,12 @@ package body Ortho_Code.X86.Insns is Left := Get_Expr_Operand (Stmt); case Reg is when R_Any32 - | Regs_R32 | R_Any64 - | Regs_R64 + | R_AnyPair + | Regs_Pair | R_Any8 | R_St0 + | Regs_R64 | Regs_Xmm | R_Any_Xmm => Reg_Res := Reg; @@ -1775,7 +2018,7 @@ package body Ortho_Code.X86.Insns is when R_Irm | R_Rm | R_Ir => - Reg_Res := Get_Reg_Any (Get_Expr_Mode (Left)); + Reg_Res := Get_Reg_Any (Left); when others => Error_Gen_Insn (Stmt, Reg); end case; @@ -1817,8 +2060,10 @@ package body Ortho_Code.X86.Insns is -- Detect for bound. null; when Mode_I64 => - -- Work on registers. - Reg_Op := R_Any64; + if not Flags.M64 then + -- Work on registers. + Reg_Op := R_AnyPair; + end if; when others => Error_Gen_Insn (Stmt, O_Mode); end case; @@ -1831,8 +2076,10 @@ package body Ortho_Code.X86.Insns is -- Detect for bound. null; when Mode_I64 => - -- Work on registers. - Reg_Op := R_Any64; + if not Flags.M64 then + -- Work on registers. + Reg_Op := R_AnyPair; + end if; when others => Error_Gen_Insn (Stmt, O_Mode); end case; @@ -1864,21 +2111,31 @@ package body Ortho_Code.X86.Insns is when Mode_I64 => -- Detect for bound (U32) Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_Edx_Eax, Num); - Free_Insn_Regs (Left); + if Flags.M64 then + -- Use movsxd to compare. + Left := Gen_Insn (Left, R_Any64, Num); + Set_Expr_Reg + (Stmt, Alloc_Reg (R_Any32, Stmt, Num)); + Free_Insn_Regs (Left); + else + -- Use cdq to compare, keep ax. + Left := Gen_Insn (Left, R_Edx_Eax, Num); + Free_Insn_Regs (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; + -- Need an extra register to compare. + Insert_Reg (Mode_U32); + end if; 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 @@ -1896,20 +2153,37 @@ package body Ortho_Code.X86.Insns is | Mode_B2 => -- Zero or Sign extend. Num := Get_Insn_Num; - Left := Gen_Insn (Left, R_Ax, Num); + if Flags.M64 then + -- Use movsxd / movl + Left := + Gen_Insn (Left, Get_Reg_Any (O_Mode), Num); + case Reg is + when Regs_R64 => + Reg1 := Reg; + when R_Any64 + | R_Rm + | R_Irm + | R_Ir => + Reg1 := R_Any64; + when others => + raise Program_Error; + end case; + else + Left := Gen_Insn (Left, R_Ax, Num); + case Reg is + when R_Edx_Eax + | R_AnyPair + | R_Rm + | R_Irm + | R_Ir => + Reg1 := R_Edx_Eax; + when others => + raise Program_Error; + end case; + end if; 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; + Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, Stmt, Pnum)); Link_Stmt (Stmt); return Stmt; when Mode_F64 @@ -1937,13 +2211,14 @@ package body Ortho_Code.X86.Insns is | R_Rm | R_Ir | R_Sib - | R_Any32 | R_Any64 + | R_Any32 + | R_AnyPair | R_Any8 | R_Any_Xmm => Reg_Res := Get_Reg_Any (Stmt); - when Regs_R32 - | Regs_R64 + when Regs_R64 + | Regs_Pair | Regs_Fp | Regs_Xmm => Reg_Res := Reg; @@ -1956,34 +2231,8 @@ package body Ortho_Code.X86.Insns is return Stmt; end; when OE_Arg => - pragma Assert (Reg = R_None); - 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. - if Abi.Flag_Sse2 then - Reg_Res := R_Any_Xmm; - else - Reg_Res := R_St0; - end if; - 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; + -- Handled by Gen_Call. + raise Program_Error; when OE_Call => return Gen_Call (Stmt, Reg, Pnum); when OE_Case_Expr => @@ -2005,16 +2254,18 @@ package body Ortho_Code.X86.Insns is procedure Assert_Free_Regs (Stmt : O_Enode) is begin - for I in Regs_R32 loop + for I in Regs_R64 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; + if not Abi.Flag_Sse2 then + 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 if; end Assert_Free_Regs; procedure Gen_Insn_Stmt (Stmt : O_Enode) @@ -2089,8 +2340,7 @@ package body Ortho_Code.X86.Insns is Free_Insn_Regs (Left); when OE_Case => Left := Gen_Insn (Get_Expr_Operand (Stmt), - Get_Reg_Any (Get_Expr_Mode (Stmt)), - Num); + Get_Reg_Any (Stmt), Num); Set_Expr_Operand (Stmt, Left); Set_Expr_Reg (Stmt, Get_Expr_Reg (Left)); Link_Stmt (Stmt); @@ -2118,9 +2368,7 @@ package body Ortho_Code.X86.Insns is end case; -- Check all registers are free. - if Debug.Flag_Debug_Assert then - Assert_Free_Regs (Stmt); - end if; + pragma Debug (Assert_Free_Regs (Stmt)); end Gen_Insn_Stmt; procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc) @@ -2144,14 +2392,39 @@ package body Ortho_Code.X86.Insns is end; end if; + Stack_Offset := 0; + Need_Fp_Conv_Slot := False; + + -- Save parameters on stack (just alloc). + -- First the integers then the floats (to use push). + if Flags.M64 then + declare + Inter : O_Dnode; + R : O_Reg; + begin + for Pass in 1 .. 2 loop + Inter := Get_Subprg_Interfaces (Subprg.D_Decl); + while Inter /= O_Dnode_Null loop + R := Get_Decl_Reg (Inter); + if (Pass = 1 and then R in Regs_R64) + or else (Pass = 2 and then R in Regs_Xmm) + then + Stack_Offset := Stack_Offset + 8; + Set_Local_Offset (Inter, - Int32 (Stack_Offset)); + end if; + Inter := Get_Interface_Chain (Inter); + end loop; + end loop; + end; + end if; + + Stack_Max := Stack_Offset; + -- Before the prologue, all registers are unused. - for I in Regs_R32 loop + for I in Regs_R64 loop Regs (I).Used := False; end loop; - Stack_Max := 0; - Stack_Offset := 0; - Need_Fp_Conv_Slot := False; First := Subprg.E_Entry; Expand_Decls (Subprg.D_Body + 1); Abi.Last_Link := First; @@ -2168,6 +2441,7 @@ package body Ortho_Code.X86.Insns is -- Allocate one stack slot for fp conversion for the whole subprogram. if Need_Fp_Conv_Slot then + pragma Assert (Abi.Flag_Sse2 and not Flags.M64); Stack_Max := Do_Align (Stack_Max, 8); Stack_Max := Stack_Max + 8; Subprg.Target.Fp_Slot := Stack_Max; @@ -2179,5 +2453,4 @@ package body Ortho_Code.X86.Insns is -- Sanity check: there must be no remaining pushed bytes. pragma Assert (Push_Offset = 0); 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 index fc20ed5..2c3331b 100644 --- a/src/ortho/mcode/ortho_code-x86-insns.ads +++ b/src/ortho/mcode/ortho_code-x86-insns.ads @@ -18,7 +18,12 @@ with Ortho_Code.Exprs; use Ortho_Code.Exprs; package Ortho_Code.X86.Insns is - function Reg_Used (Reg : Regs_R32) return Boolean; + -- Return True iff OBJ is in a different module. + -- This applies to x86-64 only as in that case RIP relative addressing + -- cannot be used. + function Is_External_Object (Obj : O_Dnode) return Boolean; + + function Reg_Used (Reg : Regs_R64) return Boolean; -- Split enodes of SUBPRG into instructions. procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc); diff --git a/src/ortho/mcode/ortho_code-x86.adb b/src/ortho/mcode/ortho_code-x86.adb index 3eb7129..9650438 100644 --- a/src/ortho/mcode/ortho_code-x86.adb +++ b/src/ortho/mcode/ortho_code-x86.adb @@ -44,7 +44,7 @@ package body Ortho_Code.X86 is end case; end Inverse_Cc; - function Get_R64_High (Reg : Regs_R64) return Regs_R32 is + function Get_Pair_High (Reg : Regs_Pair) return Regs_R32 is begin case Reg is when R_Edx_Eax => @@ -54,9 +54,9 @@ package body Ortho_Code.X86 is when R_Esi_Edi => return R_Si; end case; - end Get_R64_High; + end Get_Pair_High; - function Get_R64_Low (Reg : Regs_R64) return Regs_R32 is + function Get_Pair_Low (Reg : Regs_Pair) return Regs_R32 is begin case Reg is when R_Edx_Eax => @@ -66,6 +66,6 @@ package body Ortho_Code.X86 is when R_Esi_Edi => return R_Di; end case; - end Get_R64_Low; + end Get_Pair_Low; end Ortho_Code.X86; diff --git a/src/ortho/mcode/ortho_code-x86.ads b/src/ortho/mcode/ortho_code-x86.ads index 817b7af..bff3b4b 100644 --- a/src/ortho/mcode/ortho_code-x86.ads +++ b/src/ortho/mcode/ortho_code-x86.ads @@ -63,8 +63,9 @@ package Ortho_Code.X86 is 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_Any8 : constant O_Reg := 5; + R_Any32 : constant O_Reg := 6; + R_Any64 : constant O_Reg := 7; R_Ax : constant O_Reg := 8; R_Cx : constant O_Reg := 9; R_Dx : constant O_Reg := 10; @@ -73,18 +74,28 @@ package Ortho_Code.X86 is R_Bp : constant O_Reg := 13; R_Si : constant O_Reg := 14; R_Di : constant O_Reg := 15; + R_R8 : constant O_Reg := 16; + R_R9 : constant O_Reg := 17; + R_R10 : constant O_Reg := 18; + R_R11 : constant O_Reg := 19; + R_R12 : constant O_Reg := 20; + R_R13 : constant O_Reg := 21; + R_R14 : constant O_Reg := 22; + R_R15 : constant O_Reg := 23; 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; + subtype Regs_R64 is O_Reg range R_Ax .. R_R15; + subtype Regs_R8_R15 is O_Reg range R_R8 .. R_R15; + + R_St0 : constant O_Reg := 24; + R_St1 : constant O_Reg := 25; + R_St2 : constant O_Reg := 26; + R_St3 : constant O_Reg := 27; + R_St4 : constant O_Reg := 28; + R_St5 : constant O_Reg := 29; + R_St6 : constant O_Reg := 30; + R_St7 : constant O_Reg := 31; --R_Any_Fp : constant O_Reg := 24; subtype Regs_Fp is O_Reg range R_St0 .. R_St7; @@ -92,6 +103,7 @@ package Ortho_Code.X86 is -- Any condition register. R_Any_Cc : constant O_Reg := 32; R_Ov : constant O_Reg := 32; + R_No : constant O_Reg := 33; R_Ult : constant O_Reg := 34; R_Uge : constant O_Reg := 35; R_Eq : constant O_Reg := 36; @@ -108,9 +120,9 @@ package Ortho_Code.X86 is 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; + R_AnyPair : constant O_Reg := 67; - subtype Regs_R64 is O_Reg range R_Edx_Eax .. R_Esi_Edi; + subtype Regs_Pair is O_Reg range R_Edx_Eax .. R_Esi_Edi; R_Any_Xmm : constant O_Reg := 79; @@ -134,9 +146,10 @@ package Ortho_Code.X86 is 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; + subtype Regs_Xmm8_Xmm15 is O_Reg range R_Xmm8 .. R_Xmm15; - function Get_R64_High (Reg : Regs_R64) return Regs_R32; - function Get_R64_Low (Reg : Regs_R64) return Regs_R32; + function Get_Pair_High (Reg : Regs_Pair) return Regs_R32; + function Get_Pair_Low (Reg : Regs_Pair) return Regs_R32; function Inverse_Cc (R : O_Reg) return O_Reg; @@ -152,4 +165,11 @@ package Ortho_Code.X86 is subtype Intrinsics_X86 is Int32 range Intrinsic_Mul_Ov_U64 .. Intrinsic_Rem_Ov_I64; + type O_Reg_Array is array (Natural range <>) of O_Reg; + + -- Registers preserved accross calls. + Preserved_Regs_32 : constant O_Reg_Array := + (R_Di, R_Si, R_Bx); + Preserved_Regs_64 : constant O_Reg_Array := + (R_Bx, R_R12, R_R13, R_R14, R_R15); end Ortho_Code.X86; diff --git a/src/ortho/mcode/ortho_code_main.adb b/src/ortho/mcode/ortho_code_main.adb index b3a2e19..7290056 100644 --- a/src/ortho/mcode/ortho_code_main.adb +++ b/src/ortho/mcode/ortho_code_main.adb @@ -34,7 +34,6 @@ 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; @@ -44,12 +43,29 @@ is Res : Natural; I : Natural; Argc : Natural; + Val : Integer; procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation (Name => String_Acc, Object => String); + + procedure Write_Output + is + Fd : File_Descriptor; + begin + Fd := Create_File (Output.all, Binary); + if Fd /= Invalid_FD then + case Format is + when Format_Elf => + Binary_File.Elf.Write (Fd); + when Format_Coff => + Binary_File.Coff.Write (Fd); + end case; + Close (Fd); + end if; + end Write_Output; begin First_File := Natural'Last; Exec_Func := null; - + Val := 0; Ortho_Front.Init; Argc := Argument_Count; @@ -80,6 +96,14 @@ begin end if; Exec_Func := new String'(Argument (I + 1)); I := I + 2; + elsif Arg = "-a" then + if I = Argc then + Put_Line (Standard_Error, + "error: missing value after 'a'"); + return; + end if; + Val := Integer'Value (Argument (I + 1)); + I := I + 2; elsif Arg = "-g" then Flag_Debug := Debug_Dwarf; I := I + 1; @@ -153,42 +177,58 @@ begin 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 (Fd); - when Format_Coff => - Binary_File.Coff.Write (Fd); - end case; - Close (Fd); - end if; - elsif Exec_Func /= null then + if Exec_Func /= null then declare Sym : Symbol; - type Func_Acc is access function return Integer; + procedure Putchar (V : Integer); + pragma Import (C, Putchar); + + type Func_Acc is access function (V : Integer) return Integer; function Conv is new Ada.Unchecked_Conversion (Source => Pc_Type, Target => Func_Acc); F : Func_Acc; + + -- Set a breakpoint on this procedure under a debugger if you need + -- to debug the resulting binary in memory. + procedure Breakme (Func : Func_Acc) is + begin + F := Func; + end Breakme; + V : Integer; Err : Boolean; begin Binary_File.Memory.Write_Memory_Init; + + -- Export putchar. + Sym := Binary_File.Get_Symbol ("putchar"); + if Sym /= Null_Symbol then + Binary_File.Memory.Set_Symbol_Address (Sym, Putchar'Address); + end if; + + -- Relocate. Binary_File.Memory.Write_Memory_Relocate (Err); if Err then return; end if; + + -- Dump the binary file. + if Output /= null then + Write_Output; + 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; + Breakme (Conv (Get_Symbol_Vaddr (Sym))); + V := F.all (Val); Put_Line ("Result is " & Integer'Image (V)); end if; end; + elsif Output /= null then + Write_Output; end if; Set_Exit_Status (Success); diff --git a/src/ortho/mcode/symbolizer.adb b/src/ortho/mcode/symbolizer.adb index 79e7de2..8f60bf4 100644 --- a/src/ortho/mcode/symbolizer.adb +++ b/src/ortho/mcode/symbolizer.adb @@ -69,6 +69,19 @@ package body Symbolizer is Addr := Addr + 4; end Read_Word4; + procedure Read_Word8 (Addr : in out Address; Res : out Unsigned_64) + is + B : Unsigned_8; + begin + Res := 0; + for I in 0 .. 7 loop + B := Read_Byte (Addr + Storage_Offset (I)); + -- FIXME: we assume little-endian + Res := Res or Shift_Left (Unsigned_64 (B), I * 8); + end loop; + Addr := Addr + 8; + end Read_Word8; + procedure Read_Word2 (Addr : in out Address; Res : out Unsigned_16) is @@ -231,15 +244,32 @@ package body Symbolizer is Addr := Addr + 1; end Skip_String; - procedure Read_Addr (Addr : in out Address; - Res : out Address) - is - function To_Address is new Ada.Unchecked_Conversion - (Unsigned_32, Address); - V : Unsigned_32; + procedure Read_Addr (Addr : in out Address; Res : out Address) is begin - Read_Word4 (Addr, V); - Res := To_Address (V); + pragma Warnings (Off, "*different size*"); + if Address'Size = Unsigned_32'Size then + declare + function To_Address is new Ada.Unchecked_Conversion + (Unsigned_32, Address); + V : Unsigned_32; + begin + Read_Word4 (Addr, V); + Res := To_Address (V); + end; + elsif Address'Size = Unsigned_64'Size then + declare + function To_Address is new Ada.Unchecked_Conversion + (Unsigned_64, Address); + V : Unsigned_64; + begin + Read_Word8 (Addr, V); + Res := To_Address (V); + end; + else + -- Unhandled address size. + raise Program_Error; + end if; + pragma Warnings (On, "*different size*"); end Read_Addr; procedure Read_Addr (Addr : in out Address; diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb index afdabce..cd01eb3 100644 --- a/src/ortho/oread/ortho_front.adb +++ b/src/ortho/oread/ortho_front.adb @@ -254,9 +254,11 @@ package body Ortho_Front is | Node_Object | Node_Lit => -- Declarations + Decl_Storage : O_Storage; + -- For constants: True iff fully defined. + Decl_Defined : Boolean; -- All declarations but NODE_PROCEDURE have a type. Decl_Dtype : Node_Acc; - Decl_Storage : O_Storage; case Kind is when Decl_Type => -- Type declaration. @@ -443,7 +445,10 @@ package body Ortho_Front is Token_Number := 0; C := Get_Char; loop - Token_Number := Token_Number * Base + Unsigned_64 (To_Digit (C)); + if C /= '_' then + Token_Number := + Token_Number * Base + Unsigned_64 (To_Digit (C)); + end if; C := Get_Char; exit when C = '#'; end loop; @@ -1022,7 +1027,7 @@ package body Ortho_Front is Next_Token; Index_Node := Parse_Type; Expect (Tok_Right_Brack, "']' expected"); - Next_Expect (Tok_Of, "'of' expected"); + Next_Expect (Tok_Of, "'OF' expected"); Next_Token; El_Node := Parse_Type; Res := new Node' @@ -1034,6 +1039,8 @@ package body Ortho_Front is end; return Res; when Tok_Subarray => + -- Grammar: + -- SUBARRAY type [ len ] declare Base_Node : Node_Acc; Res_Type : O_Tnode; @@ -1122,6 +1129,7 @@ package body Ortho_Front is False_Lit := new Node'(Kind => Node_Lit, Decl_Dtype => Res, Decl_Storage => O_Storage_Public, + Decl_Defined => False, Lit_Name => Token_Sym.Ident, Lit_Cnode => O_Cnode_Null, Lit_Next => null); @@ -1130,6 +1138,7 @@ package body Ortho_Front is True_Lit := new Node'(Kind => Node_Lit, Decl_Dtype => Res, Decl_Storage => O_Storage_Public, + Decl_Defined => False, Lit_Name => Token_Sym.Ident, Lit_Cnode => O_Cnode_Null, Lit_Next => null); @@ -1141,6 +1150,8 @@ package body Ortho_Front is True_Lit.Lit_Name, True_Lit.Lit_Cnode); end; when Tok_Enum => + -- Grammar: + -- ENUM { LIT1, LIT2, ... LITN } declare List : O_Enum_List; Lit : Node_Acc; @@ -1160,6 +1171,7 @@ package body Ortho_Front is Lit := new Node'(Kind => Node_Lit, Decl_Dtype => Res, Decl_Storage => O_Storage_Public, + Decl_Defined => False, Lit_Name => Token_Sym.Ident, Lit_Cnode => O_Cnode_Null, Lit_Next => null); @@ -1171,9 +1183,13 @@ package body Ortho_Front is Last_Lit.Lit_Next := Lit; end if; Last_Lit := Lit; - Next_Expect (Tok_Equal); - Next_Expect (Tok_Num); + Next_Token; + if Tok = Tok_Equal then + -- By compatibility, support '= N' after a literal. + Next_Expect (Tok_Num); + Next_Token; + end if; exit when Tok = Tok_Right_Brace; Expect (Tok_Comma); Next_Token; @@ -1504,6 +1520,9 @@ package body Ortho_Front is begin Parse_Name (Name, Lval, Res_Type); Res := New_Value (Lval); + if Atype /= null and then Res_Type /= Atype then + Parse_Error ("type mismatch"); + end if; end; else Parse_Error ("bad ident expression: " @@ -2029,6 +2048,12 @@ package body Ortho_Front is end; when Tok_Case => + -- Grammar: + -- CASE expr IS + -- WHEN lit => + -- WHEN lit ... lit => + -- WHEN DEFAULT => + -- END CASE; declare Case_Blk : O_Case_Block; L : O_Cnode; @@ -2121,6 +2146,7 @@ package body Ortho_Front is P := new Node'(Kind => Decl_Param, Decl_Dtype => null, Decl_Storage => O_Storage_Public, + Decl_Defined => False, Param_Node => O_Dnode_Null, Param_Name => Token_Sym, Param_Next => null); @@ -2232,6 +2258,7 @@ package body Ortho_Front is N := new Node'(Kind => Node_Function, Decl_Dtype => null, Decl_Storage => Storage, + Decl_Defined => False, Subprg_Node => O_Dnode_Null, Subprg_Name => Sym, Subprg_Params => null); @@ -2270,6 +2297,7 @@ package body Ortho_Front is N := new Node'(Kind => Node_Procedure, Decl_Dtype => null, Decl_Storage => Storage, + Decl_Defined => False, Subprg_Node => O_Dnode_Null, Subprg_Name => Sym, Subprg_Params => null); @@ -2367,13 +2395,12 @@ package body Ortho_Front is case Atype.Kind is when Type_Subarray => declare + El : constant Node_Acc := Atype.Subarray_Base.Array_Element; Constr : O_Array_Aggr_List; - El : Node_Acc; begin Expect (Tok_Left_Brace); Next_Token; Start_Array_Aggr (Constr, Atype.Type_Onode); - El := Atype.Subarray_Base.Array_Element; for I in Natural loop exit when Tok = Tok_Right_Brace; if I /= 0 then @@ -2452,7 +2479,7 @@ package body Ortho_Front is is N : Node_Acc; Sym : Syment_Acc; - --Val : O_Cnode; + Val : O_Cnode; begin Expect (Tok_Constant); Next_Expect (Tok_Ident); @@ -2460,6 +2487,7 @@ package body Ortho_Front is N := new Node'(Kind => Node_Object, Decl_Dtype => null, Decl_Storage => Storage, + Decl_Defined => False, Obj_Name => Sym.Ident, Obj_Node => O_Dnode_Null); Next_Expect (Tok_Colon); @@ -2468,15 +2496,18 @@ package body Ortho_Front is New_Const_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode); Add_Decl (Sym, N); --- if Storage /= O_Storage_External then --- Expect (Tok_Assign); --- Next_Token; --- Start_Const_Value (N.Obj_Node); --- Val := Parse_Constant_Value (N.Decl_Dtype); --- Finish_Const_Value (N.Obj_Node, Val); --- end if; + if Tok = Tok_Assign then + N.Decl_Defined := True; + Next_Token; + + Start_Const_Value (N.Obj_Node); + Val := Parse_Constant_Value (N.Decl_Dtype); + Finish_Const_Value (N.Obj_Node, Val); + end if; end Parse_Constant_Declaration; + -- Grammar: + -- CONSTANT ident := value ; procedure Parse_Constant_Value_Declaration is N : Node_Acc; @@ -2487,6 +2518,11 @@ package body Ortho_Front is if N.Kind /= Node_Object then Parse_Error ("name of a constant expected"); end if; + if N.Decl_Defined then + Parse_Error ("constant already defined"); + else + N.Decl_Defined := True; + end if; -- FIXME: should check storage, -- should check the object is a constant, -- should check the object has no value. @@ -2508,6 +2544,7 @@ package body Ortho_Front is N := new Node'(Kind => Node_Object, Decl_Dtype => null, Decl_Storage => Storage, + Decl_Defined => False, Obj_Name => Sym.Ident, Obj_Node => O_Dnode_Null); Next_Expect (Tok_Colon); @@ -2530,7 +2567,7 @@ package body Ortho_Front is elsif Tok = Tok_Var then Parse_Var_Declaration (Storage); else - Parse_Error ("function declaration expected"); + Parse_Error ("function or object declaration expected"); end if; end Parse_Stored_Decl; @@ -2557,6 +2594,7 @@ package body Ortho_Front is else Inter := new Node'(Kind => Decl_Type, Decl_Storage => O_Storage_Public, + Decl_Defined => False, Decl_Dtype => Parse_Type); Add_Decl (S, Inter); New_Type_Decl (S.Ident, Inter.Decl_Dtype.Type_Onode); @@ -2664,7 +2702,6 @@ package body Ortho_Front is else declare Name : String (1 .. Filename'Length + 1); - --("C:\cygwin\home\tgingold\src\ortho\x86\tests\olang\ex2.ol", begin Name (1 .. Filename'Length) := Filename.all; Name (Name'Last) := NUL; @@ -2692,6 +2729,8 @@ package body Ortho_Front is end if; return True; exception + when Error => + return False; when E : others => Puterr (Ada.Exceptions.Exception_Information (E)); raise; diff --git a/src/ortho/oread/tests/full.on b/src/ortho/oread/tests/full.on new file mode 100644 index 0000000..4b4d189 --- /dev/null +++ b/src/ortho/oread/tests/full.on @@ -0,0 +1,1012 @@ +TYPE int32 IS SIGNED (32); +TYPE uns32 IS UNSIGNED (32); +TYPE char8 IS UNSIGNED (8); + +TYPE enum8 IS ENUM {e8_0, e8_1, e8_2}; + +TYPE string8 IS ARRAY [uns32] OF char8; +TYPE string_acc IS ACCESS string8; + +TYPE bool IS BOOLEAN {false, true}; + +TYPE float IS FLOAT; + +TYPE int64 IS SIGNED (64); +TYPE uns64 IS UNSIGNED (64); + +TYPE int32_acc IS ACCESS int32; +TYPE int64_acc IS ACCESS int64; + +-- Some constants. +PRIVATE CONSTANT zero_i32 : int32 := 0; +PRIVATE CONSTANT zero_u32 : uns32 := 0; +PRIVATE CONSTANT zero_u8 : char8 := 0; +PRIVATE CONSTANT zero_u64 : uns64 := 0; +PRIVATE CONSTANT zero_i64 : int64 := 0; +PRIVATE CONSTANT zero_fp : float := 0.0; +PRIVATE CONSTANT zero_enum8 : enum8 := enum8'[e8_0]; + +PRIVATE CONSTANT true_bool : bool := bool'[true]; +PRIVATE CONSTANT false_bool : bool := bool'[false]; + +-- Array of size 5 bytes +TYPE arr5 IS SUBARRAY string8[5]; +TYPE arr5_array IS ARRAY [uns32] OF arr5; + +PRIVATE VAR v_arr5_4: SUBARRAY arr5_array[4]; + +-- Record of 2 words. +TYPE rec8 IS RECORD a : int32; b : int32; END RECORD; +TYPE rec8_array IS ARRAY [uns32] OF rec8; +-- Array of size 2 words and 8 words +TYPE int32_array IS ARRAY [uns32] OF int32; +TYPE arr32 IS SUBARRAY int32_array[8]; +TYPE arr32_array IS ARRAY [uns32] OF arr32; + +PRIVATE VAR v_rec8_2: SUBARRAY rec8_array[2]; +PRIVATE VAR v_arr32_3: SUBARRAY arr32_array[3]; + +-- Write a character on the standard output. +EXTERNAL PROCEDURE putchar (v : int32); + +-- Exit status. +PRIVATE VAR status : int32; + +PRIVATE CONSTANT banner1 : SUBARRAY string8[6]; +CONSTANT banner1 := { 'h', 'e', 'l', 'l', 'o', 10 }; + +PRIVATE CONSTANT banner1_acc : string_acc := string_acc'address (banner1); +PRIVATE CONSTANT null_acc : string_acc := string_acc'[NULL]; + +-- Disp the LEN first characters of S. +PRIVATE PROCEDURE disp_lstr (s : string_acc; len : uns32) +DECLARE + LOCAL VAR i : uns32; +BEGIN + i := 0; + LOOP 1: + IF bool'(i = len) THEN + EXIT LOOP 1; + END IF; + putchar (int32'conv (s.ALL[i])); + i := i +# 1; + END LOOP; +END; + +-- Disp a NUL terminated string. +PRIVATE PROCEDURE puts (s : string_acc) +DECLARE + LOCAL VAR i : uns32; + LOCAL VAR c : char8; +BEGIN + i := 0; + LOOP 1: + c := s.ALL[i]; + IF bool'(c = 0) THEN + EXIT LOOP 1; + END IF; + putchar (int32'conv (c)); + i := i +# 1; + END LOOP; +END; + +PRIVATE PROCEDURE putn (n : uns32) +DECLARE + LOCAL VAR n1 : uns32; + LOCAL VAR d : uns32; +BEGIN + d := '0' +# (n MOD# 10); + n1 := n /# 10; + IF bool'(n1 /= 0) THEN + putn (n1); + END IF; + putchar (int32'conv (d)); +END; + +PRIVATE PROCEDURE putn_nl (n : uns32) +DECLARE +BEGIN + putn (n); + putchar (10); +END; + +PRIVATE CONSTANT str_test : SUBARRAY string8[7]; +CONSTANT str_test := { 'T', 'e', 's', 't', ' ', '#', 0 }; + +PRIVATE VAR test_num : uns32; + +PRIVATE PROCEDURE disp_test () +DECLARE +BEGIN + puts (string_acc'address(str_test)); + putn (test_num); + putchar (10); + test_num := test_num +# 1; +END; + +PRIVATE FUNCTION add2 (a : int32; b : int32) RETURN int32 +DECLARE +BEGIN + RETURN a +# b; +END; + +PRIVATE FUNCTION add8 (a : uns32; b : uns32; c : uns32; d : uns32; + e : uns32; f : uns32; g : uns32; h : uns32) + RETURN uns32 +DECLARE +BEGIN + RETURN a +# (b +# (c +# (d +# (e +# (f +# (g +# h)))))); +END; + +PRIVATE PROCEDURE puti32 (n : int32) +DECLARE + TYPE str8x11 IS SUBARRAY string8[11]; + LOCAL VAR s : str8x11; + LOCAL VAR is_neg : bool; + LOCAL VAR i : uns32; + LOCAL VAR n1 : int32; + LOCAL VAR d : int32; +BEGIN + IF bool'(n < 0) THEN + is_neg := bool'[true]; + n1 := -n; + ELSE + is_neg := bool'[false]; + n1 := n; + END IF; + i := 9; + s[10] := 0; + LOOP 1: + d := '0' +# (n1 MOD# 10); + s[i] := char8'conv (d); + n1 := n1 /# 10; + IF bool'(n1 = 0) THEN + EXIT LOOP 1; + END IF; + i := i -# 1; + END LOOP; + IF is_neg THEN + i := i -# 1; + s[i] := '-'; + END IF; + puts(string_acc'address(s[i...])); +END; + + +PRIVATE PROCEDURE error () +DECLARE + PRIVATE CONSTANT str_error : SUBARRAY string8[8]; + CONSTANT str_error := { 'E', 'R', 'R', 'O', 'R', '!', 10, 0 }; +BEGIN + status := 1; + puts (string_acc'address(str_error)); +END; + +PRIVATE PROCEDURE check_i32 (a : int32; ref : int32) +DECLARE +BEGIN + puti32 (a); + putchar (10); + IF bool'(a /= ref) THEN + error (); + END IF; +END; + +PRIVATE CONSTANT str_true : SUBARRAY string8[5]; +CONSTANT str_true := { 'T', 'r', 'u', 'e', 0 }; + +PRIVATE CONSTANT str_false : SUBARRAY string8[6]; +CONSTANT str_false := { 'F', 'a', 'l', 's', 'e', 0 }; + +PRIVATE PROCEDURE check_bool (a : bool; ref : bool) +DECLARE +BEGIN + IF a THEN + puts(string_acc'address(str_true)); + ELSE + puts(string_acc'address(str_false)); + END IF; + putchar (10); + IF bool'(a /= ref) THEN + error (); + END IF; +END; + +PRIVATE CONSTANT str_float : SUBARRAY string8[13]; +CONSTANT str_float := + { 'F', 'l', 'o', 'a', 't', ' ', 't', 'e', 's', 't', 's', 10, 0 }; + +PRIVATE PROCEDURE check_float (a : float; ref : float) +DECLARE +BEGIN + IF bool'(a /= ref) THEN + error (); + END IF; +END; + +PRIVATE FUNCTION add_float (a : float; b : float) RETURN float +DECLARE +BEGIN + RETURN a +# b; +END; + +PRIVATE FUNCTION add3_float (a : float; b : float; c : float) RETURN float +DECLARE +BEGIN + RETURN add_float (a, add_float (b, c)); +END; + +PRIVATE PROCEDURE check_i64 (a : int64; ref : int64) +DECLARE +BEGIN +-- puti32 (a); +-- putchar (10); + IF bool'(a /= ref) THEN + error (); + END IF; +END; + +PRIVATE FUNCTION add2_i64 (a : int64; b : int64) RETURN int64 +DECLARE +BEGIN + RETURN a +# b; +END; + +PRIVATE FUNCTION andn (a : bool; b : bool) RETURN bool +DECLARE +BEGIN + RETURN a AND (NOT b); +END; + +PRIVATE FUNCTION cmpi32 (a : int32) RETURN bool +DECLARE +BEGIN + RETURN a >= 0; +END; + +PRIVATE PROCEDURE check_u32 (a : uns32; ref : uns32) +DECLARE +BEGIN + IF bool'(a /= ref) THEN + error (); + END IF; +END; + +PRIVATE PROCEDURE check_u64 (a : uns64; ref : uns64) +DECLARE +BEGIN + IF bool'(a /= ref) THEN + error (); + END IF; +END; + +PRIVATE PROCEDURE check_enum8 (a : enum8; ref : enum8) +DECLARE +BEGIN + IF bool'(a /= ref) THEN + error (); + END IF; +END; + +-- To test alloca +PRIVATE PROCEDURE disp_indent (n : uns32) +DECLARE + LOCAL VAR i : uns32; + LOCAL VAR ptr : string_acc; +BEGIN + ptr := string_acc'alloca (n +# 1); + ptr.ALL[n] := 0; + LOOP 1: + IF bool'(n = 0) THEN + EXIT LOOP 1; + END IF; + n := n -# 1; + ptr.ALL[n] := 32; + END LOOP; + puts (ptr); +END; + +PRIVATE PROCEDURE test_case () +DECLARE + LOCAL VAR i : int32; + PRIVATE CONSTANT str_zero : SUBARRAY string8[5]; + CONSTANT str_zero := { 'z', 'e', 'r', 'o', 0 }; + PRIVATE CONSTANT str_one : SUBARRAY string8[4]; + CONSTANT str_one := { 'o', 'n', 'e', 0 }; + PRIVATE CONSTANT str_two_four : SUBARRAY string8[9]; + CONSTANT str_two_four := { 't', 'w', 'o', '-', 'f', 'o', 'u', 'r', 0 }; + PRIVATE CONSTANT str_five_plus : SUBARRAY string8[6]; + CONSTANT str_five_plus := { 'f', 'i', 'v', 'e', '+', 0 }; +BEGIN + i := 0; + LOOP 1: + IF bool'(i = 6) THEN + EXIT LOOP 1; + END IF; + CASE i IS + WHEN 0 => puts (string_acc'address (str_zero)); + WHEN 1 => puts (string_acc'address (str_one)); + WHEN 2 ... 4 => puts (string_acc'address (str_two_four)); + WHEN DEFAULT => puts (string_acc'address (str_five_plus)); + END CASE; + putchar (10); + i := i +# 1; + END LOOP; +END; + +PRIVATE PROCEDURE call_9iargs (i1 : int64; i2 : int64; i3 : int64; i4 : int64; + i5 : int64; i6 : int64; i7 : int64; i8 : int64; + i9 : int64) +DECLARE +BEGIN + IF bool'((i1 +# (i2 +# (i3 +# (i4 +# (i5 +# (i6 +# (i7 +# (i8 +# i9)))))))) + /= 45) + THEN + error (); + END IF; +END; + +PRIVATE PROCEDURE call_9fargs (i1 : float; i2 : float; i3 : float; i4 : float; + i5 : float; i6 : float; i7 : float; i8 : float; + i9 : float) +DECLARE +BEGIN + IF bool'((i1 +# (i2 +# (i3 +# (i4 +# (i5 +# (i6 +# (i7 +# (i8 +# i9)))))))) + /= 45.0) + THEN + error (); + END IF; +END; + +PRIVATE PROCEDURE call_nested (a : int32; b : int32; c : int32) +DECLARE + PRIVATE PROCEDURE nested (d : int32) + DECLARE + BEGIN + puti32 (d); + putchar (10); + puti32 (a); + putchar (10); + IF bool'((a +# (b +# d)) /= 7) THEN + error (); + END IF; + END; +BEGIN + nested (c +# 1); +END; + +PRIVATE VAR g_int32_ptr : int32_acc; + +PRIVATE PROCEDURE call_arg_addr (a : int32; b : int64; c : float) +DECLARE + LOCAL VAR ap : int32_acc; + LOCAL VAR bp : int64_acc; +BEGIN + ap := int32_acc'address (zero_i32); + + ap := int32_acc'address (a); + bp := int64_acc'address (b); + + g_int32_ptr := int32_acc'address (a); + + IF bool'(ap.ALL /= 1) THEN + error (); + END IF; + IF bool'(bp.ALL /= 2) THEN + error (); + END IF; +END; + +PUBLIC FUNCTION main () RETURN int32 +DECLARE +BEGIN + -- Start with a simple banner. + putchar ('h'); + putchar (10); + + -- Real banner. + disp_lstr (string_acc'address(banner1), 6); + + -- Test assignment to a global and putn. + test_num := 3; + putn (test_num); + putchar (10); + + status := 0; + + -- Start of tests. + test_num := 4; + disp_test (); + -- Test putn with more than 1 digit. + putn_nl (125); + + -- Nested calls. + disp_test (); + putn_nl (uns32'conv (add2 (7, add2 (5, 3)))); -- 15 + + -- Many parameters + disp_test (); + putn_nl (add8 (1, 2, 3, 4, 5, 6, 7, 8)); -- 36 + + -- Nested with many parameters + disp_test (); + putn_nl (add8 (1, 2, 3, 4, 5, 6, + add8 (10, 11, 12, 13, 14, 15, 16, 17), 8)); -- 137 + + -- Test puti32 + disp_test (); + puti32 (15679); + putchar (10); + + -- Test puti32 + disp_test (); + puti32 (-45678); + putchar (10); + + DECLARE + LOCAL VAR v1 : int32; + LOCAL VAR v2 : int32; + BEGIN + v1 := 12; + v2 := -15; + + -- Arith i32: add + disp_test (); + check_i32 (v1 +# 5, 17); + + -- Arith i32: sub + disp_test (); + check_i32 (v1 -# 5, 7); + + -- Arith i32: mul + disp_test (); + check_i32 (v1 *# 9, 108); + + -- Arith i32: div + disp_test (); + check_i32 (v1 /# 4, 3); + check_i32 (v2 /# 6, -2); + + -- Arith i32: abs + disp_test (); + check_i32 (ABS v1, 12); + check_i32 (ABS v2, 15); + + -- Arith i32: neg + disp_test (); + check_i32 (-v1, -12); + check_i32 (-v2, 15); + + -- Arith i32: rem (sign of the dividend) + disp_test (); + check_i32 (v1 REM# 5, 2); + check_i32 (v1 REM# (-5), 2); + check_i32 (v2 REM# 4, -3); + check_i32 (v2 REM# (-4), -3); + + -- Arith i32: mod (sign of the divisor) + disp_test (); + check_i32 (v1 MOD# 5, 2); + check_i32 (v1 MOD# (-5), -3); + check_i32 (v2 MOD# 4, 1); + check_i32 (v2 MOD# (-4), -3); + + -- Comparaisons + disp_test (); + check_bool (bool'(v1 > 11), bool'[true]); + check_bool (bool'(v1 < 16), bool'[true]); + check_bool (bool'(v1 <= 9), bool'[false]); + check_bool (bool'(v1 >= 22), bool'[false]); + check_bool (bool'(v1 /= 21), bool'[true]); + check_bool (bool'(v1 = 17), bool'[false]); + + -- Conversions. + disp_test (); + check_i32 (int32'conv (zero_i32), 0); + check_i32 (int32'conv (zero_u32), 0); + check_i32 (int32'conv (zero_u8), 0); +-- check_i32 (int32'conv (zero_u64), 0); -- Never supported. + check_i32 (int32'conv (zero_i64), 0); + check_i32 (int32'conv (zero_fp), 0); + check_i32 (int32'conv (true_bool), 1); + check_i32 (int32'conv (false_bool), 0); + check_i32 (int32'conv (zero_enum8), 0); + END; + + DECLARE + LOCAL VAR v1 : float; + LOCAL VAR v2 : float; + BEGIN + v1 := 3.5; + v2 := -2.25; + + puts(string_acc'address (str_float)); + + -- function call + disp_test (); + check_float (add_float (v1, v2), 1.25); + + -- function call + disp_test (); + check_float (add3_float (v1, v2, v1), 4.75); + + -- Arith fp: add + disp_test (); + check_float (v1 +# 5.5, 9.0); + + -- Arith fp: sub + disp_test (); + check_float (v1 -# 5.25, -1.75); + + -- Arith fp: mul + disp_test (); + check_float (v1 *# 4.0, 14.0); + + -- Arith fp: div + disp_test (); + check_float (v1 /# 0.5, 7.0); + check_float (v2 /# 2.0, -1.125); + + -- Arith fp: abs + disp_test (); + check_float (ABS v1, 3.5); + check_float (ABS v2, 2.25); + + -- Arith fp: neg + disp_test (); + check_float (-v1, -3.5); + check_float (-v2, 2.25); + + -- Comparaisons + disp_test (); + check_bool (bool'(v1 > 3.0), bool'[true]); + check_bool (bool'(v1 < 3.75), bool'[true]); + check_bool (bool'(v1 <= 2.5), bool'[false]); + check_bool (bool'(v1 >= 4.0), bool'[false]); + check_bool (bool'(v1 /= 1.25), bool'[true]); + check_bool (bool'(v1 = 0.25), bool'[false]); + + -- Conversions. + disp_test (); + check_float (float'conv (zero_i32), 0.0); +-- Others were never supported. +-- check_float (float'conv (zero_u32), 0.0); +-- check_float (float'conv (zero_u8), 0.0); +-- check_float (float'conv (zero_u64), 0.0); + check_float (float'conv (zero_i64), 0.0); + check_float (float'conv (zero_fp), 0.0); +-- check_float (float'conv (true_bool), 1.0); +-- check_float (float'conv (false_bool), 0.0); + END; + + DECLARE + LOCAL VAR v1 : int64; + LOCAL VAR v2 : int64; + BEGIN + v1 := 14; + v2 := -11; + + -- i64 call + disp_test (); + check_i64 (add2_i64 (v1, 5), 19); + + -- Arith i64: add + disp_test (); + check_i64 (v1 +# 5, 19); + + -- Arith i64: sub + disp_test (); + check_i64 (v1 -# 4, 10); + + -- Arith i64: mul + disp_test (); + check_i64 (v1 *# 3, 42); + check_i64 (v2 *# 6, -66); + + -- Arith i64: div + disp_test (); + check_i64 (v1 /# 3, 4); + check_i64 (v2 /# -5, 2); + + -- Arith i64: abs + disp_test (); + check_i64 (ABS v1, 14); + check_i64 (ABS v2, 11); + + -- Arith i64: neg + disp_test (); + check_i64 (-v1, -14); + check_i64 (-v2, 11); + + -- Arith i64: rem (sign of the dividend) + disp_test (); + check_i64 (v1 REM# 5, 4); + check_i64 (v1 REM# (-5), 4); + check_i64 (v2 REM# 4, -3); + check_i64 (v2 REM# (-4), -3); + + -- Arith i64: mod (sign of the divisor) + disp_test (); + check_i64 (v1 MOD# 5, 4); + check_i64 (v1 MOD# (-5), -1); + check_i64 (v2 MOD# 4, 1); + check_i64 (v2 MOD# (-4), -3); + + -- Arith i64: large constants + disp_test (); + check_i64 (v1 +# 16#01234567_89abcdef#, 16#01234567_89abcdfd#); + + -- Comparaisons + disp_test (); + check_bool (bool'(v1 > 11), bool'[true]); + check_bool (bool'(v1 < 16), bool'[true]); + check_bool (bool'(v1 <= 9), bool'[false]); + check_bool (bool'(v1 >= 22), bool'[false]); + check_bool (bool'(v1 /= 21), bool'[true]); + check_bool (bool'(v1 = 17), bool'[false]); + + -- Conversions. + disp_test (); + check_i64 (int64'conv (zero_i32), 0); + check_i64 (int64'conv (zero_u32), 0); + check_i64 (int64'conv (zero_u8), 0); +-- check_i64 (int64'conv (zero_u64), 0); -- Never supported. + check_i64 (int64'conv (zero_i64), 0); + check_i64 (int64'conv (zero_fp), 0); + check_i64 (int64'conv (true_bool), 1); + check_i64 (int64'conv (false_bool), 0); + END; + + DECLARE + LOCAL VAR t : bool; + LOCAL VAR f : bool; + BEGIN + t := bool'[true]; + f := bool'[false]; + + -- Test function call + disp_test (); + check_bool (andn (t, f), bool'[true]); + check_bool (cmpi32 (12), bool'[true]); + IF cmpi32 (-5) THEN + error (); + END IF; + + -- Test or + disp_test (); + check_bool (t OR f, bool'[true]); + check_bool (t OR t, bool'[true]); + check_bool (f OR t, bool'[true]); + check_bool (f OR f, bool'[false]); + + -- Test and + disp_test (); + check_bool (t AND f, bool'[false]); + check_bool (t AND t, bool'[true]); + check_bool (f AND t, bool'[false]); + check_bool (f AND f, bool'[false]); + + -- Test xor + disp_test (); + check_bool (t XOR f, bool'[true]); + check_bool (t XOR t, bool'[false]); + check_bool (f XOR t, bool'[true]); + check_bool (f XOR f, bool'[false]); + + -- Test not + disp_test (); + check_bool (NOT t, bool'[false]); + check_bool (NOT f, bool'[true]); + + -- Test operators in if. + disp_test (); + IF bool'(t < f) THEN + error (); + END IF; + IF NOT bool'(t > f) THEN + error (); + END IF; + IF bool'(t = f) OR bool'(f >= t) THEN + error (); + END IF; + IF f THEN + error (); + END IF; + IF bool'[false] THEN + error (); + END IF; + + -- Comparaisons + disp_test (); + check_bool (bool'(t > f), bool'[true]); + check_bool (bool'(t < f), bool'[false]); + check_bool (bool'(t <= f), bool'[false]); + check_bool (bool'(f >= t), bool'[false]); + check_bool (bool'(f /= t), bool'[true]); + check_bool (bool'(t = f), bool'[false]); + + -- Conversions. + disp_test (); + check_bool (bool'conv (zero_i32), bool'[false]); + check_bool (bool'conv (zero_u32), bool'[false]); +-- check_bool (bool'conv (zero_u8), bool'[false]); +-- check_bool (int64'conv (zero_u64), bool'[false]); -- Never supported. + check_bool (bool'conv (zero_i64), bool'[false]); +-- check_bool (bool'conv (zero_fp), bool'[false]); + check_bool (bool'conv (true_bool), bool'[true]); + check_bool (bool'conv (false_bool), bool'[false]); + END; + + DECLARE + LOCAL VAR v1 : uns32; + LOCAL VAR v2 : uns32; + BEGIN + v1 := 120; + v2 := 7; + + -- Arith u32: add + disp_test (); + check_u32 (v1 +# 5, 125); + + -- Arith u32: sub + disp_test (); + check_u32 (v1 -# 4, 116); + + -- Arith u32: mul + disp_test (); + check_u32 (v1 *# 3, 360); + + -- Arith u32: div + disp_test (); + check_u32 (v1 /# 6, 20); + + -- Arith u32: rem (sign of the dividend) + disp_test (); + check_u32 (v2 REM# 3, 1); + + -- Comparaisons + disp_test (); + check_bool (bool'(v1 > 10), bool'[true]); + check_bool (bool'(v1 < 16), bool'[false]); + check_bool (bool'(v1 <= 9), bool'[false]); + check_bool (bool'(v1 >= 22), bool'[true]); + check_bool (bool'(v1 /= 21), bool'[true]); + check_bool (bool'(v1 = 17), bool'[false]); + + -- Conversions. + disp_test (); + check_u32 (uns32'conv (zero_i32), 0); + check_u32 (uns32'conv (zero_u32), 0); + check_u32 (uns32'conv (zero_u8), 0); +-- check_u32 (uns32'conv (zero_u64), 0); -- Never supported. +-- check_u32 (uns32'conv (zero_i64), 0); +-- check_u32 (uns32'conv (zero_fp), 0); + check_u32 (uns32'conv (true_bool), 1); + check_u32 (uns32'conv (false_bool), 0); + + -- bitwise operators + disp_test (); + check_u32 (v2 AND 3, 3); + check_u32 (v2 OR 8, 15); + check_u32 (NOT v2, 16#ffff_fff8#); + END; + + DECLARE + LOCAL VAR v1 : uns64; + LOCAL VAR v2 : uns64; + BEGIN + v1 := 120; + v2 := 7; + + -- Arith u64: add + disp_test (); + check_u64 (v1 +# 5, 125); + + -- Arith u64: sub + disp_test (); + check_u64 (v1 -# 4, 116); + + -- Arith u64: mul + disp_test (); + check_u64 (v1 *# 3, 360); + + -- Arith u64: div + disp_test (); + check_u64 (v1 /# 6, 20); + + -- Arith u64: rem (sign of the dividend) + disp_test (); + check_u64 (v2 REM# 3, 1); + + -- Comparaisons + disp_test (); + check_bool (bool'(v1 > 10), bool'[true]); + check_bool (bool'(v1 < 16), bool'[false]); + check_bool (bool'(v1 <= 9), bool'[false]); + check_bool (bool'(v1 >= 22), bool'[true]); + check_bool (bool'(v1 /= 21), bool'[true]); + check_bool (bool'(v1 = 17), bool'[false]); + + -- Conversions. + disp_test (); +-- check_u64 (uns64'conv (zero_i32), 0); +-- check_u64 (uns64'conv (zero_u32), 0); +-- check_u64 (uns64'conv (zero_u8), 0); + check_u64 (uns64'conv (zero_u64), 0); -- Never supported. +-- check_u64 (uns64'conv (zero_i64), 0); +-- check_u64 (uns64'conv (zero_fp), 0); +-- check_u64 (uns64'conv (true_bool), 1); +-- check_u64 (uns64'conv (false_bool), 0); + + -- bitwise operators + disp_test (); + check_u64 (v2 AND 3, 3); + check_u64 (v2 OR 8, 15); + check_u64 ((NOT v2) AND 255, 16#f8#); + END; + + DECLARE + LOCAL VAR v1 : enum8; + LOCAL VAR v2 : enum8; + BEGIN + v1 := enum8'[e8_1]; + v2 := enum8'[e8_0]; + + -- Comparaisons + disp_test (); + check_bool (bool'(v1 > enum8'[e8_0]), bool'[true]); + check_bool (bool'(v1 < enum8'[e8_1]), bool'[false]); + check_bool (bool'(v1 <= enum8'[e8_1]), bool'[true]); + check_bool (bool'(v1 >= enum8'[e8_2]), bool'[false]); + check_bool (bool'(v1 /= enum8'[e8_0]), bool'[true]); + check_bool (bool'(v1 = enum8'[e8_0]), bool'[false]); + + -- Conversions. + disp_test (); + check_enum8 (enum8'conv (zero_i32), enum8'[e8_0]); +-- check_u64 (uns64'conv (zero_u32), 0); +-- check_u64 (uns64'conv (zero_u8), 0); +-- check_u64 (uns64'conv (zero_u64), 0); -- Never supported. +-- check_u64 (uns64'conv (zero_i64), 0); +-- check_u64 (uns64'conv (zero_fp), 0); +-- check_u64 (uns64'conv (true_bool), 1); +-- check_u64 (uns64'conv (false_bool), 0); + END; + + -- Test alloca + disp_test (); + disp_indent (5); + putchar ('|'); + putchar (10); + disp_indent (17); + putchar ('|'); + putchar (10); + + -- Test case + disp_test (); + test_case (); + + -- Test indexes + DECLARE + LOCAL VAR i: uns32; + LOCAL VAR l_arr5_4 : SUBARRAY arr5_array[4]; + BEGIN + disp_test (); + -- Write + i := 0; + LOOP 1: + IF bool'(i = 4) THEN + EXIT LOOP 1; + END IF; + v_arr5_4[i][0] := 2; + l_arr5_4[i][1] := v_arr5_4[i][0] +# 1; + v_arr5_4[i][2] := l_arr5_4[i][1] +# 1; + i := i +# 1; + END LOOP; + -- Check + i := 0; + LOOP 1: + IF bool'(i = 4) THEN + EXIT LOOP 1; + END IF; + IF bool'(v_arr5_4[i][2] /= 4) THEN + error (); + END IF; + IF bool'(l_arr5_4[i][1] /= 3) THEN + error (); + END IF; + i := i +# 1; + END LOOP; + END; + + DECLARE + LOCAL VAR i: uns32; + LOCAL VAR l_rec8_2 : SUBARRAY rec8_array[2]; + BEGIN + disp_test (); + -- Write + i := 0; + LOOP 1: + IF bool'(i = 2) THEN + EXIT LOOP 1; + END IF; + v_rec8_2[i].a := 2; + l_rec8_2[i].a := v_rec8_2[i].a +# 1; + v_rec8_2[i].b := l_rec8_2[i].a +# 1; + i := i +# 1; + END LOOP; + -- Check + i := 0; + LOOP 1: + IF bool'(i = 2) THEN + EXIT LOOP 1; + END IF; + IF bool'(v_rec8_2[i].b /= 4) THEN + error (); + END IF; + IF bool'(l_rec8_2[i].a /= 3) THEN + error (); + END IF; + i := i +# 1; + END LOOP; + END; + + DECLARE + LOCAL VAR i: uns32; + LOCAL VAR l_arr32_3 : SUBARRAY arr32_array[3]; + BEGIN + disp_test (); + -- Write + i := 0; + LOOP 1: + IF bool'(i = 3) THEN + EXIT LOOP 1; + END IF; + v_arr32_3[i][0] := 2; + l_arr32_3[i][1] := v_arr32_3[i][0] +# 1; + v_arr32_3[i][3] := l_arr32_3[i][1] +# 1; + l_arr32_3[i][5] := v_arr32_3[i][3] +# 1; + i := i +# 1; + END LOOP; + -- Check + i := 0; + LOOP 1: + IF bool'(i = 3) THEN + EXIT LOOP 1; + END IF; + IF bool'(l_arr32_3[i][5] /= 5) THEN + error (); + END IF; + IF bool'(v_arr32_3[i][3] /= 4) THEN + error (); + END IF; + i := i +# 1; + END LOOP; + END; + + -- Call with more than 8 params. + disp_test(); + call_9iargs (1, 2, 3, 4, 5, 6, 7, 8, 9); + + disp_test(); + call_9fargs (1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0); + + -- nested subprograms + disp_test(); + call_nested (1, 2, 3); + + -- Access in constant + disp_test (); + puts (banner1_acc); + + -- Address of argument + disp_test (); + call_arg_addr (1, 2, 3.0); + + -- TODO: + -- U8 + -- Spill (use div, mod). + -- R12 and R13 in SIB. + + RETURN status; +END; |