freepascal.compiler/compiler/og386elf.pas

{
    $Id$
    Copyright (c) 1998-2000 by Peter Vreman

    Contains the binary elf writer

    * This code was inspired by the NASM sources
      The Netwide Assembler is copyright (C) 1996 Simon Tatham and
      Julian Hall. All rights reserved.

    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, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************
}
unit og386elf;

  interface

    uses
       cobjects,og386,cpubase,aasm;

    const
      R_386_32 = 1;                    { ordinary absolute relocation }
      R_386_PC32 = 2;                  { PC-relative relocation }
      R_386_GOT32 = 3;                 { an offset into GOT }
      R_386_PLT32 = 4;                 { a PC-relative offset into PLT }
      R_386_GOTOFF = 9;                { an offset from GOT base }
      R_386_GOTPC = 10;                { a PC-relative offset _to_ GOT }

      SHT_PROGBITS = 1;
      SHT_NOBITS = 8;

      SHF_WRITE = 1;
      SHF_ALLOC = 2;
      SHF_EXECINSTR = 4;

    type
       preloc = ^treloc;
       treloc = packed record
          next     : preloc;
          address  : longint;
          symbol   : pasmsymbol;
          {section  : tsection;} { only used if symbol=nil }
          typ      : byte;
       end;

       psymbol = ^tsymbol;
       tsymbol = packed record
         strpos  : longint;
         section : longint;
         value   : longint;
         typ     : TAsmsymtype;
         size    : longint;
         globnum : longint;
         next,
         nextfwd : psymbol;
       end;

       pelfsection = ^telfsection;
       telfsection = object
          index : tsection;
          data  : PDynamicArray;
          len,
          pos,
          nrelocs,
          flags     : longint;
          relochead : PReloc;
          reloctail : ^PReloc;

          rel       : PDynamicArray;
          gsyms     : PSymbol;

          constructor init(sec:TSection;Aflags:longint);
          destructor  done;
          procedure  write(var d;l:longint);
          procedure  alloc(l:longint);
          procedure  addsymreloc(ofs:longint;p:pasmsymbol;relative:relative_type);
          procedure  addsectionreloc(ofs:longint;sec:tsection);
       end;

       pelfoutput = ^telfoutput;
       telfoutput = object(tobjectoutput)
         sects   : array[TSection] of PElfSection;
         elf_gotpc_sect,
         elf_gotoff_sect,
         elf_got_sect,
         elf_plt_sect,
         elf_sym_sect  : PElfSection;
         strs,
         syms    : Pdynamicarray;
         initsym : longint;
         constructor init;
         destructor  done;virtual;
         procedure initwriting;virtual;
         procedure donewriting;virtual;
         procedure writebytes(var data;len:longint);virtual;
         procedure writealloc(len:longint);virtual;
         procedure writereloc(data,len:longint;p:pasmsymbol;relative:relative_type);virtual;
         procedure writesymbol(p:pasmsymbol);virtual;
         procedure writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc:boolean);virtual;
       private
         procedure createsection(sec:tsection);
         procedure write_relocs(s:pcoffsection);
         procedure write_symbol(const name:string;strpos,value,section,typ,aux:longint);
         procedure write_symbols;
         procedure writetodisk;
       end;


  implementation

      uses
        strings,verbose,
        globtype,globals,files;

      type
      { Structures which are written directly to the output file }


      const
        sec_2_str : array[tsection] of string[8]=('',
          '.text','.data','.bss',
          '.stab','.stabstr',
          '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata',
          ''
        );


{****************************************************************************
                               TSection
****************************************************************************}

    constructor tcoffsection.init(sec:TSection;Aflags:longint);
      begin
        index:=sec;
        flags:=AFlags;
        relocHead:=nil;
        relocTail:=@relocHead;
        Len:=0;
        NRelocs:=0;
        if sec=sec_bss then
         data:=nil
        else
         new(Data,Init(1,8192));
      end;


    destructor tcoffsection.done;
      begin
        if assigned(Data) then
          dispose(Data,done);
      end;


    procedure  tcoffsection.write(var d;l:longint);
      begin
        if not assigned(Data) then
         Internalerror(3334441);
        Data^.write(d,l);
        inc(len,l);
      end;


    procedure  tcoffsection.alloc(l:longint);
      begin
        if assigned(Data) then
         Internalerror(3334442);
        inc(len,l);
      end;


    procedure tcoffsection.addsymreloc(ofs:longint;p:pasmsymbol;relative:relative_type);
      var
        r : PReloc;
      begin
        new(r);
        reloctail^:=r;
        reloctail:=@r^.next;
        r^.next:=nil;
        r^.address:=ofs;
        r^.symbol:=p;
        r^.section:=sec_none;
        r^.relative:=relative;
        inc(nrelocs);
      end;


    procedure tcoffsection.addsectionreloc(ofs:longint;sec:tsection);
      var
        r : PReloc;
      begin
        new(r);
        reloctail^:=r;
        reloctail:=@r^.next;
        r^.next:=nil;
        r^.address:=ofs;
        r^.symbol:=nil;
        r^.section:=sec;
        r^.relative:=relative_false;
        inc(nrelocs);
      end;


{****************************************************************************
                            Genericcoffoutput
****************************************************************************}

    const
{$ifdef TP}
      symbolresize = 50;
      strsresize   = 200;
{$else}
      symbolresize = 200;
      strsresize   = 8192;
{$endif}

    constructor tgenericcoffoutput.init;
      begin
        inherited init;
      end;


    destructor tgenericcoffoutput.done;
      begin
        inherited done;
      end;


    procedure tgenericcoffoutput.initwriting;
      var
        s : string;
      begin
        inherited initwriting;
        { reset }
        initsym:=0;
        new(syms,init(sizeof(TSymbol),symbolresize));
        new(strs,init(1,strsresize));
        FillChar(Sects,sizeof(Sects),0);
        { we need at least the following 3 sections }
        createsection(sec_code);
        createsection(sec_data);
        createsection(sec_bss);
        if (cs_debuginfo in aktmoduleswitches) then
         begin
           createsection(sec_stab);
           createsection(sec_stabstr);
           writestabs(sec_none,0,nil,0,0,0,false);
           { write zero pchar and name together (PM) }
           s:=#0+SplitFileName(current_module^.mainsource^)+#0;
           sects[sec_stabstr]^.write(s[1],length(s));
         end;
      end;


    procedure tgenericcoffoutput.donewriting;
      var
        sec : tsection;
      begin
        writetodisk;
        dispose(syms,done);
        dispose(strs,done);
        for sec:=low(tsection) to high(tsection) do
         if assigned(sects[sec]) then
          dispose(sects[sec],done);
        inherited donewriting;
      end;


    function tgenericcoffoutput.text_flags : longint;
      begin
        text_flags:=0;
      end;

    function tgenericcoffoutput.data_flags : longint;
      begin
        data_flags:=0;
      end;

    function tgenericcoffoutput.bss_flags : longint;
      begin
        bss_flags:=0;
      end;

    function tgenericcoffoutput.info_flags : longint;
      begin
        info_flags:=0;
      end;


    procedure tgenericcoffoutput.createsection(sec:TSection);
      var
        Aflags : longint;
      begin
        Aflags:=0;
        case sec of
          sec_code :
            Aflags:=text_flags;
          sec_data :
            Aflags:=data_flags;
          sec_bss :
            Aflags:=bss_flags;
        { sec_info :
            Aflags:=info_flags; }
          else
            Aflags:=0;
        end;
        sects[sec]:=new(PcoffSection,init(Sec,Aflags));
      end;


    procedure tgenericcoffoutput.writesymbol(p:pasmsymbol);
      var
        pos : longint;
        sym : tsymbol;
        c   : char;
        s   : string;
      begin
        { already written ? }
        if p^.idx<>-1 then
         exit;
        { be sure that the section will exists }
        if (p^.section<>sec_none) and not(assigned(sects[p^.section])) then
          createsection(p^.section);
        { symbolname }
        pos:=strs^.usedsize+4;
        c:=#0;
        s:=p^.name;
        if length(s)>8 then
         begin
           s:=s+#0;
           strs^.write(s[1],length(s));
         end
        else
         pos:=-1;
        FillChar(sym,sizeof(sym),0);
        sym.strpos:=pos;
        if pos=-1 then
         sym.name:=s;
        sym.value:=p^.size;
        sym.typ:=p^.typ;
        { if local of global then set the section value to the address
          of the symbol }
        if p^.typ in [AS_LOCAL,AS_GLOBAL] then
         begin
           sym.section:=ord(p^.section);
           sym.value:=p^.address;
         end;
        { update the asmsymbol index }
        p^.idx:=syms^.count;
        { store the symbol, but not the local ones (PM) }
        if (p^.typ<>AS_LOCAL) or ((copy(s,1,2)<>'.L') and
          ((copy(s,1,1)<>'L') or not win32)) then
          syms^.write(sym,1);
        { make the exported syms known to the objectwriter
          (needed for .a generation) }
        if (p^.typ=AS_GLOBAL) or
           ((p^.typ=AS_EXTERNAL) and (sym.value=p^.size) and (sym.value>0)) then
          writer^.writesym(p^.name);
      end;


    procedure tgenericcoffoutput.writebytes(var data;len:longint);
      begin
        if not assigned(sects[currsec]) then
         createsection(currsec);
        sects[currsec]^.write(data,len);
      end;


    procedure tgenericcoffoutput.writealloc(len:longint);
      begin
        if not assigned(sects[currsec]) then
         createsection(currsec);
        sects[currsec]^.alloc(len);
      end;


    procedure tgenericcoffoutput.writereloc(data,len:longint;p:pasmsymbol;relative:relative_type);
      begin
        if not assigned(sects[currsec]) then
         createsection(currsec);
        if assigned(p) then
         begin
           { no symbol relocation need inside a section }
           if p^.section=currsec then
             begin
               if relative=relative_false then
                 begin
                   sects[currsec]^.addsectionreloc(sects[currsec]^.len,currsec);
                   inc(data,p^.address);
                 end
               else if relative=relative_true then
                 begin
                   inc(data,p^.address-len-sects[currsec]^.len);
                 end
               else if relative=relative_rva then
                 begin
                   { don't know if this can happens !! }
                   { does this work ?? }
                   sects[currsec]^.addsectionreloc(sects[currsec]^.len,currsec);
                   inc(data,p^.address);
                 end;
             end
           else
             begin
               writesymbol(p);
               if (p^.section<>sec_none) and (relative=relative_false) then
                 begin
                   sects[currsec]^.addsectionreloc(sects[currsec]^.len,p^.section);
                 end
               else
                 sects[currsec]^.addsymreloc(sects[currsec]^.len,p,relative);
               if not win32 then {seems wrong to me (PM) }
                begin
                  {if p^.section<>sec_none then
                    this is the cause of the strange
                    feature see Note (5) before
                    address contains the size for
                    global vars switched to common }
                    inc(data,p^.address);
                end
               else
                if (relative<>relative_true) and (p^.section<>sec_none) then
                 inc(data,p^.address);
               if relative=relative_true then
                begin
                  if win32 then
                    {inc(data,4-len)}
                    dec(data,len-4{+p^.address})
                  else
                    dec(data,len+sects[currsec]^.len);
                end;
            end;
         end;
        sects[currsec]^.write(data,len);
      end;


    procedure tgenericcoffoutput.writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc : boolean);
      var
        stab : coffstab;
        s : tsection;
      begin
        if section=sec_none then
         s:=currsec
        else
         s:=section;
        { local var can be at offset -1 !! PM }
        if (offset=-1) and reloc then
         begin
           if s=sec_none then
            offset:=0
           else
            offset:=sects[s]^.len;
         end;
        fillchar(stab,sizeof(coffstab),0);
        if assigned(p) and (p[0]<>#0) then
         begin
           stab.strpos:=sects[sec_stabstr]^.len;
           sects[sec_stabstr]^.write(p^,strlen(p)+1);
         end;
        stab.ntype:=nidx;
        stab.ndesc:=line;
        stab.nother:=nother;
        stab.nvalue:=offset;
        sects[sec_stab]^.write(stab,sizeof(stab));
        { when the offset is not 0 then write a relocation, take also the
          hdrstab into account with the offset }
        if reloc then
          sects[sec_stab]^.addsectionreloc(sects[sec_stab]^.len-4,s);
      end;


    procedure tgenericcoffoutput.write_relocs(s:pcoffsection);
      var
        rel  : coffreloc;
        hr,r : preloc;
      begin
        r:=s^.relochead;
        while assigned(r) do
         begin
           rel.address:=r^.address;
           if assigned(r^.symbol) then
            begin
              if (r^.symbol^.typ=AS_LOCAL) then
               rel.sym:=2*ord(r^.symbol^.section)
              else
               rel.sym:=r^.symbol^.idx+initsym;
            end
           else
            rel.sym:=2*ord(r^.section);
           case r^.relative of
             relative_true  : rel.relative:=$14;
             relative_false : rel.relative:=$6;
             relative_rva   : rel.relative:=$7;
           end;
           writer^.write(rel,sizeof(rel));
           { goto next and dispose this reloc }
           hr:=r;
           r:=r^.next;
           dispose(hr);
         end;
      end;


    procedure tgenericcoffoutput.write_symbol(const name:string;strpos,value,section,typ,aux:longint);
      var
        sym : coffsymbol;
      begin
        FillChar(sym,sizeof(sym),0);
        if strpos=-1 then
         move(name[1],sym.name,length(name))
        else
         sym.strpos:=strpos;
        sym.value:=value;
        sym.section:=section;
        sym.typ:=typ;
        sym.aux:=aux;
        writer^.write(sym,sizeof(sym));
      end;


    procedure tgenericcoffoutput.write_symbols;
      var
        filename : string[18];
        sec : tsection;
        i   : longint;
        globalval : byte;
        secrec : coffsectionrec;
        sym : tsymbol;
      begin
        { The `.file' record, and the file name auxiliary record. }
        write_symbol ('.file', -1, 0, -2, $67, 1);
        fillchar(filename,sizeof(filename),0);
        filename:=SplitFileName(current_module^.mainsource^);
        writer^.write(filename[1],sizeof(filename)-1);
        { The section records, with their auxiliaries }
        i:=0;
        for sec:=low(tsection) to high(tsection) do
         if assigned(sects[sec]) then
          begin
            inc(i);
            write_symbol(sec_2_str[sec],-1,{sects[sec]^.pos}0,i,3,1);
            fillchar(secrec,sizeof(secrec),0);
            secrec.len:=sects[sec]^.len;
            secrec.nrelocs:=sects[sec]^.nrelocs;
            writer^.write(secrec,sizeof(secrec));
          end;
        { The real symbols. }
        syms^.seek(0);
        for i:=1 to syms^.count do
         begin
           syms^.read(sym,1);
           if sym.typ=AS_LOCAL then
             globalval:=3
           else
             globalval:=2;
           write_symbol(sym.name,sym.strpos,sym.value,sym.section,globalval,0);
         end;
      end;


    procedure tgenericcoffoutput.writetodisk;
      var
        datapos,
        nsects,pos,sympos,i,fillsize : longint;
        sec    : tsection;
        header : coffheader;
        sechdr : coffsechdr;
        empty  : array[0..15] of byte;
      begin
      { calc amount of sections we have and align sections at 4 bytes }
        fillchar(empty,sizeof(empty),0);
        nsects:=0;
        for sec:=low(tsection) to high(tsection) do
        { .stabstr section length must be without alignment !! }
         if assigned(sects[sec]) then
          begin
          { fill with zero }
            fillsize:=4-(sects[sec]^.len and 3);
            if fillsize<>4 then
             begin
               if assigned(sects[sec]^.data) then
                 sects[sec]^.write(empty,fillsize)
               else
                 sects[sec]^.alloc(fillsize);
               { .stabstr section length must be without alignment !! }
               if (sec=sec_stabstr) then
                 dec(sects[sec]^.len,fillsize);
             end;
            inc(nsects);
          end;
      { Calculate the filepositions }
        datapos:=sizeof(coffheader)+sizeof(coffsechdr)*nsects;
        pos:=0;
        initsym:=2; { 2 for the file }
        { sections first }
        for sec:=low(tsection) to high(tsection) do
         if assigned(sects[sec]) then
          begin
            sects[sec]^.pos:=pos;
            sects[sec]^.datapos:=datapos;
            inc(pos,sects[sec]^.len);
            if assigned(sects[sec]^.data) then
              inc(datapos,sects[sec]^.len);
            { align after stabstr section !! }
            if (sec=sec_stabstr) and ((sects[sec]^.len and 3)<>0) then
              inc(datapos,4-(sects[sec]^.len and 3));
            inc(initsym,2); { 2 for each section }
          end;
        { relocs }
        for sec:=low(tsection) to high(tsection) do
         if assigned(sects[sec]) then
          begin
            sects[sec]^.relocpos:=datapos;
            inc(datapos,10*sects[sec]^.nrelocs);
          end;
        { symbols }
        sympos:=datapos;
      { COFF header }
        fillchar(header,sizeof(coffheader),0);
        header.mach:=$14c;
        header.nsects:=nsects;
        header.sympos:=sympos;
        header.syms:=syms^.count+initsym;
        if not win32 then
         header.flag:=$104;
        writer^.write(header,sizeof(header));
      { Section headers }
        for sec:=low(tsection) to high(tsection) do
         if assigned(sects[sec]) then
          begin
            fillchar(sechdr,sizeof(sechdr),0);
            move(sec_2_str[sec][1],sechdr.name,length(sec_2_str[sec]));
            if not win32 then
              sechdr.vsize:=sects[sec]^.pos
            else if sec=sec_bss then
              sechdr.vsize:=sects[sec]^.len;
            sechdr.datalen:=sects[sec]^.len;
            { apparently win32 asw leaves section at datapos zero }
            { this was an error by me (PM) }
            if (sects[sec]^.len>0) and assigned(sects[sec]^.data) then
              sechdr.datapos:=sects[sec]^.datapos;
            sechdr.relocpos:=sects[sec]^.relocpos;
            sechdr.nrelocs:=sects[sec]^.nrelocs;
            sechdr.flags:=sects[sec]^.flags;
            writer^.write(sechdr,sizeof(sechdr));
          end;
      { Sections }
        for sec:=low(tsection) to high(tsection) do
         if assigned(sects[sec]) and
            assigned(sects[sec]^.data) then
          begin
            { For the stab section we need an HdrSym which can now be
              calculated more easily }
            if sec=sec_stab then
             begin
               pcoffstab(sects[sec_stab]^.data^.data)^.nvalue:=sects[sec_stabstr]^.len;
               pcoffstab(sects[sec_stab]^.data^.data)^.strpos:=1;
               pcoffstab(sects[sec_stab]^.data^.data)^.ndesc:=
                 (sects[sec_stab]^.len div sizeof(coffstab))-1{+1 according to gas output PM};
             end;
            writer^.write(sects[sec]^.data^.data^,sects[sec]^.data^.usedsize);
          end;
      { Relocs }
        for sec:=low(tsection) to high(tsection) do
         if assigned(sects[sec]) then
          write_relocs(sects[sec]);
      { Symbols }
        write_symbols;
      { Strings }
        i:=strs^.usedsize+4;
        writer^.write(i,4);
        writer^.write(strs^.data^,strs^.usedsize);
      end;


{****************************************************************************
                            DJGppcoffoutput
****************************************************************************}

    constructor tdjgppcoffoutput.init;
      begin
        inherited init;
        win32:=false;
      end;

    function tdjgppcoffoutput.text_flags : longint;
      begin
        text_flags:=$20;
      end;

    function tdjgppcoffoutput.data_flags : longint;
      begin
        data_flags:=$40;
      end;

    function tdjgppcoffoutput.bss_flags : longint;
      begin
        bss_flags:=$80;
      end;

    function tdjgppcoffoutput.info_flags : longint;
      begin
        writeln('djgpp coff doesn''t support info sections');
        info_flags:=$40;
      end;


{****************************************************************************
                            Win32coffoutput
****************************************************************************}

    constructor twin32coffoutput.init;
      begin
        inherited init;
        win32:=true;
      end;

    function twin32coffoutput.text_flags : longint;
      begin
        text_flags:={ $60500020}$60300020{changed to get same as asw.exe (PM)};
      end;

    function twin32coffoutput.data_flags : longint;
      begin
        data_flags:=$c0300040;
      end;

    function twin32coffoutput.bss_flags : longint;
      begin
        bss_flags:=$c0300080;
      end;

    function twin32coffoutput.info_flags : longint;
      begin
        info_flags:=$100a00;
      end;


end.
{
  $Log$
  Revision 1.5  2000-03-19 18:46:50  peter
    * some beginning

}