path: root/src/ortho/mcode/binary_file-elf.adb

--  Binary file ELF writer.
--  Copyright (C) 2006 Tristan Gingold
--
--  This program 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 of the License, or
--  (at your option) any later version.
--
--  This program 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 this program.  If not, see <gnu.org/licenses>.
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;

   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 Elf_Arch;
      use GNAT.OS_Lib;

      procedure Xwrite (Data : System.Address; Len : Natural) is
      begin
         if Write (Fd, Data, Len) /= Len then
            raise Write_Error;
         end if;
      end Xwrite;

      procedure Check_File_Pos (Off : 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 "
                      & Elf_Off'Image (Off) & ", found "
                      & Long_Integer'Image (L));
            raise Write_Error;
         end if;
      end Check_File_Pos;

      function Sect_Align (V : Elf_Off) return Elf_Off
      is
         Tmp : Elf_Off;
      begin
         Tmp := V + 2 ** 2 - 1;
         return Tmp - (Tmp mod 2 ** 2);
      end Sect_Align;

      type Section_Info_Type is record
         Sect : Section_Acc;
         --  Index of the section symbol (in symtab).
         Sym : 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 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;

      --  The first 4 sections are always present.
      Sect_Null : constant Natural := 0;
      Sect_Shstrtab : constant Natural := 1;
      Sect_Symtab : constant Natural := 2;
      Sect_Strtab : constant Natural := 3;
      Sect_First : constant Natural := 4;

      Offset : Elf_Off;

      --  Size of a relocation entry.
      Rel_Size : Natural;

      --  If true, do local relocs.
      Flag_Reloc : constant Boolean := True;
      --  If true, discard local symbols;
      Flag_Discard_Local : Boolean := True;

      --  Number of symbols.
      Nbr_Symbols : Natural := 0;
   begin
      --  If relocations are not performs, then local symbols cannot be
      --  discarded.
      if not Flag_Reloc then
         Flag_Discard_Local := False;
      end if;

      --  Set size of a relocation entry.  This avoids severals conditionnal.
      if Is_Rela (Arch) then
         Rel_Size := Elf_Rela_Size;
      else
         Rel_Size := Elf_Rel_Size;
      end if;

      --  Set section header.

      --  SHT_NULL.
      Shdr (Sect_Null) :=
        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) :=
        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) :=
        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) :=
        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 => Elf_Word (Nbr_Symbols));
         Nbr_Symbols := Nbr_Symbols + 1;
         Sect.Number := Nbr_Sect;

         Shdr (Nbr_Sect) :=
           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;
         if (Sect.Flags and Section_Read) /= 0 then
            Shdr (Nbr_Sect).Sh_Flags :=
              Shdr (Nbr_Sect).Sh_Flags or SHF_ALLOC;
         end if;
         if (Sect.Flags and Section_Exec) /= 0 then
            Shdr (Nbr_Sect).Sh_Flags :=
              Shdr (Nbr_Sect).Sh_Flags or SHF_EXECINSTR;
         end if;
         if (Sect.Flags and Section_Write) /= 0 then
            Shdr (Nbr_Sect).Sh_Flags :=
              Shdr (Nbr_Sect).Sh_Flags or SHF_WRITE;
         end if;
         if Sect.Flags = Section_Strtab then
            Shdr (Nbr_Sect).Sh_Type := SHT_STRTAB;
            Shdr (Nbr_Sect).Sh_Addralign := 1;
            Shdr (Nbr_Sect).Sh_Entsize := 0;
         end if;

         Shdr (Sect_Shstrtab).Sh_Size := Shdr (Sect_Shstrtab).Sh_Size
           + Sect.Name'Length + 1;      -- 1 for Nul.

         Nbr_Sect := Nbr_Sect + 1;
         if Flag_Reloc then
            if Sect.First_Reloc /= null then
               Do_Intra_Section_Reloc (Sect);
            end if;
         end if;
         if Sect.First_Reloc /= null then
            --  Add a section for the relocs.
            Shdr (Nbr_Sect) := 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 => Elf_Word (Sect_Symtab),
               Sh_Info => Elf_Word (Nbr_Sect - 1),
               Sh_Addralign => 4,
               Sh_Entsize => Elf_Size (Rel_Size));

            if Is_Rela (Arch) then
               Shdr (Nbr_Sect).Sh_Type := SHT_RELA;
            else
               Shdr (Nbr_Sect).Sh_Type := SHT_REL;
            end if;
            Shdr (Sect_Shstrtab).Sh_Size := Shdr (Sect_Shstrtab).Sh_Size
              + Sect.Name'Length + 4        --  4 for ".rel"
              + Boolean'Pos (Is_Rela (Arch)) + 1; -- 1 for 'a', 1 for Nul.

            Nbr_Sect := Nbr_Sect + 1;
         end if;
         Sect := Sect.Next;

         pragma Warnings (On);
      end loop;

      --  Lay-out sections.
      Offset := Elf_Off (Elf_Ehdr_Size);

      --  Section table
      Offset := Offset + Elf_Off (Nbr_Sect * Elf_Shdr_Size);

      --  shstrtab.
      Shdr (Sect_Shstrtab).Sh_Offset := Offset;

      Offset := Sect_Align (Offset + Shdr (Sect_Shstrtab).Sh_Size);

      --  user-sections and relocation.
      for I in Sect_First .. Nbr_Sect - 1 loop
         Sect := Sections (I).Sect;
         if Sect /= null then
            Sect.Pc := Pow_Align (Sect.Pc, Sect.Align);
            Shdr (Sect.Number).Sh_Size := Elf_Size (Sect.Pc);
            if Sect.Data /= null then
               --  Set data offset.
               Shdr (Sect.Number).Sh_Offset := Offset;
               Offset := Offset + Shdr (Sect.Number).Sh_Size;

               --  Set relocs offset.
               if Sect.First_Reloc /= null then
                  Shdr (Sect.Number + 1).Sh_Offset := Offset;
                  Shdr (Sect.Number + 1).Sh_Size :=
                    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 := Elf_Word (Sect.Link.Number);
            end if;
         end if;
      end loop;

      --  Number symbols, put local before globals.
      Nbr_Symbols := 1 + Nbr_Sections;

      --  First local symbols.
      for I in Symbols.First .. Symbols.Last loop
         case Get_Scope (I) is
            when Sym_Private =>
               Set_Number (I, Nbr_Symbols);
               Nbr_Symbols := Nbr_Symbols + 1;
            when Sym_Local =>
               if not Flag_Discard_Local then
                  Set_Number (I, Nbr_Symbols);
                  Nbr_Symbols := Nbr_Symbols + 1;
               end if;
            when Sym_Undef
              | Sym_Global =>
               null;
         end case;
      end loop;

      Shdr (Sect_Symtab).Sh_Info := Elf_Word (Nbr_Symbols);

      --  Then globals.
      for I in Symbols.First .. Symbols.Last loop
         case Get_Scope (I) is
            when Sym_Private
              | Sym_Local =>
               null;
            when Sym_Undef =>
               if Get_Used (I) then
                  Set_Number (I, Nbr_Symbols);
                  Nbr_Symbols := Nbr_Symbols + 1;
               end if;
            when Sym_Global =>
               Set_Number (I, Nbr_Symbols);
               Nbr_Symbols := Nbr_Symbols + 1;
         end case;
      end loop;

      --  Symtab.
      Shdr (Sect_Symtab).Sh_Offset := Offset;
      --  1 for nul.
      Shdr (Sect_Symtab).Sh_Size := Elf_Size (Nbr_Symbols * Elf_Sym_Size);

      Offset := Offset + Shdr (Sect_Symtab).Sh_Size;

      --  Strtab offset.
      Shdr (Sect_Strtab).Sh_Offset := Offset;
      Shdr (Sect_Strtab).Sh_Size := 1;

      --  Compute length of strtab.
      --    First, sections names.
      Sect := Section_Chain;
--       while Sect /= null loop
--          Shdr (Sect_Strtab).Sh_Size :=
--            Shdr (Sect_Strtab).Sh_Size + Sect.Name'Length + 1;
--          Sect := Sect.Prev;
--       end loop;
      --   Then symbols.
      declare
         Len : Natural;
         L : Natural;
      begin
         Len := 0;
         for I in Symbols.First .. Symbols.Last loop
            L := Get_Symbol_Name_Length (I) + 1;
            case Get_Scope (I) is
               when Sym_Local =>
                  if Flag_Discard_Local then
                     L := 0;
                  end if;
               when Sym_Private =>
                  null;
               when Sym_Global =>
                  null;
               when Sym_Undef =>
                  if not Get_Used (I) then
                     L := 0;
                  end if;
            end case;
            Len := Len + L;
         end loop;

         Shdr (Sect_Strtab).Sh_Size :=
           Shdr (Sect_Strtab).Sh_Size + Elf_Size (Len);
      end;

      --  Write file header.
      declare
         Ehdr : Elf_Ehdr;
      begin
         Ehdr := (E_Ident => (EI_MAG0 => ELFMAG0,
                              EI_MAG1 => ELFMAG1,
                              EI_MAG2 => ELFMAG2,
                              EI_MAG3 => ELFMAG3,
                              EI_CLASS => ELFCLASSNONE,
                              EI_DATA => ELFDATANONE,
                              EI_VERSION => EV_CURRENT,
                              EI_PAD .. 15 => 0),
                  E_Type => ET_REL,
                  E_Machine => EM_NONE,
                  E_Version => Elf_Word (EV_CURRENT),
                  E_Entry => 0,
                  E_Phoff => 0,
                  E_Shoff => Elf_Off (Elf_Ehdr_Size),
                  E_Flags => 0,
                  E_Ehsize => Elf_Half (Elf_Ehdr_Size),
                  E_Phentsize => 0,
                  E_Phnum => 0,
                  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, Elf_Ehdr_Size);
      end;

      -- Write shdr.
      Xwrite (Shdr'Address, Nbr_Sect * Elf_Shdr_Size);

      -- Write shstrtab
      Check_File_Pos (Shdr (Sect_Shstrtab).Sh_Offset);
      declare
         Str : String :=
           NUL & ".shstrtab" & NUL & ".symtab" & NUL & ".strtab" & NUL;
         Rela : String := NUL & ".rela";
      begin
         Xwrite (Str'Address, Str'Length);
         Sect := Section_Chain;
         while Sect /= null loop
            Xwrite (Sect.Name.all'Address, Sect.Name'Length);
            if Sect.First_Reloc /= null then
               if Is_Rela (Arch) then
                  Xwrite (Rela'Address, Rela'Length);
               else
                  Xwrite (Rela'Address, Rela'Length - 1);
               end if;
               Xwrite (Sect.Name.all'Address, Sect.Name'Length);
            end if;
            Xwrite (NUL'Address, 1);
            Sect := Sect.Next;
         end loop;
      end;
      --  Pad.
      declare
         Delt : Elf_Size;
         Nul_Str : String (1 .. 4) := (others => NUL);
      begin
         Delt := Shdr (Sect_Shstrtab).Sh_Size and 3;
         if Delt /= 0 then
            Xwrite (Nul_Str'Address, Natural (4 - Delt));
         end if;
      end;

      --  Write sections content and reloc.
      for I in 1 .. Nbr_Sect loop
         Sect := Sections (I).Sect;
         if Sect /= null then
            if Sect.Data /= null then
               Check_File_Pos (Shdr (Sect.Number).Sh_Offset);
               Xwrite (Sect.Data (0)'Address, Natural (Sect.Pc));
            end if;
            declare
               R : Reloc_Acc;
               Rel : Elf_Rel;
               Rela : Elf_Rela;
               S : Elf_Word;
               T : Elf_Word;
               Nbr_Reloc : Natural;
            begin
               R := Sect.First_Reloc;
               Nbr_Reloc := 0;
               while R /= null loop
                  if R.Done then
                     S := Sections (Get_Section (R.Sym).Number).Sym;
                  else
                     S := Elf_Word (Get_Number (R.Sym));
                  end if;

                  if Is_Rela (Arch) then
                     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 := 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 =>
                           T := Elf32.R_386_32;
                        when Reloc_Pc32 =>
                           T := Elf32.R_386_PC32;
                        when others =>
                           raise Program_Error;
                     end case;
                     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;
               end loop;
               if Nbr_Reloc /= Sect.Nbr_Relocs then
                  raise Program_Error;
               end if;
            end;
         end if;
      end loop;

      --  Write symbol table.
      Check_File_Pos (Shdr (Sect_Symtab).Sh_Offset);
      declare
         Str_Off : Elf_Off;

         procedure Gen_Sym (S : Symbol)
         is
            Sym : Elf_Sym;
            Bind : Elf_Uchar;
            Typ : Elf_Uchar;
         begin
            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 := Elf_Half (Get_Section (S).Number);
            end if;
            case Get_Scope (S) is
               when Sym_Private
                 | Sym_Local =>
                  Bind := STB_LOCAL;
                  Typ := STT_NOTYPE;
               when Sym_Global =>
                  Bind := STB_GLOBAL;
                  if Get_Section (S) /= null
                    and then (Get_Section (S).Flags and Section_Exec) /= 0
                  then
                     Typ := STT_FUNC;
                  else
                     Typ := STT_OBJECT;
                  end if;
               when Sym_Undef =>
                  Bind := STB_GLOBAL;
                  Typ := STT_NOTYPE;
            end case;
            Sym.St_Info := Elf_St_Info (Bind, Typ);

            Xwrite (Sym'Address, Elf_Sym_Size);

            Str_Off := Str_Off + Elf_Off (Get_Symbol_Name_Length (S) + 1);
         end Gen_Sym;

         Sym : Elf_Sym;
      begin

         Str_Off := 1;

         --   write null entry
         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 := 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;

         --  First local symbols.
         for I in Symbols.First .. Symbols.Last loop
            case Get_Scope (I) is
               when Sym_Private =>
                  Gen_Sym (I);
               when Sym_Local =>
                  if not Flag_Discard_Local then
                     Gen_Sym (I);
                  end if;
               when Sym_Global
                 | Sym_Undef =>
                  null;
            end case;
         end loop;

         --  Then global symbols.
         for I in Symbols.First .. Symbols.Last loop
            case Get_Scope (I) is
               when Sym_Global =>
                  Gen_Sym (I);
               when Sym_Undef =>
                  if Get_Used (I) then
                     Gen_Sym (I);
                  end if;
               when Sym_Private
                 | Sym_Local =>
                  null;
            end case;
         end loop;
      end;

      -- Write strtab.
      Check_File_Pos (Shdr (Sect_Strtab).Sh_Offset);
      --  First is NUL.
      Xwrite (NUL'Address, 1);

      --  Then the symbols name.
      declare
         procedure Write_Sym_Name (S : Symbol)
         is
            Str : String := Get_Symbol_Name (S) & NUL;
         begin
            Xwrite (Str'Address, Str'Length);
         end Write_Sym_Name;
      begin
         --  First locals.
         for I in Symbols.First .. Symbols.Last loop
            case Get_Scope (I) is
               when Sym_Private =>
                  Write_Sym_Name (I);
               when Sym_Local =>
                  if not Flag_Discard_Local then
                     Write_Sym_Name (I);
                  end if;
               when Sym_Global
                 | Sym_Undef =>
                  null;
            end case;
         end loop;

         --  Then global symbols.
         for I in Symbols.First .. Symbols.Last loop
            case Get_Scope (I) is
               when Sym_Global =>
                  Write_Sym_Name (I);
               when Sym_Undef =>
                  if Get_Used (I) then
                     Write_Sym_Name (I);
                  end if;
               when Sym_Private
                 | Sym_Local =>
                  null;
            end case;
         end loop;
      end;
   end Write;

end Binary_File.Elf;