fpc/compiler/ogcoff.pas

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

    Contains the binary coff reader and 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 ogcoff;

{$i defines.inc}

interface

    uses
       { common }
       cclasses,cobjects,
       { target }
       systems,
       { assembler }
       cpubase,aasm,
       { output }
       ogbase;

    type
       tcoffsection = class(tobjectsection)
       public
          flags    : cardinal;
          relocpos : longint;
          constructor createsec(sec:TSection;AAlign,AFlags:cardinal);
       end;

       tcoffdata = class(tobjectdata)
       private
         win32   : boolean;
         procedure reset;
       public
         constructor createdjgpp;
         constructor createwin32;
         destructor  destroy;override;
         procedure setsectionsizes(var s:tsecsize);override;
         procedure createsection(sec:tsection);override;
         procedure writereloc(data,len:longint;p:pasmsymbol;relative:relative_type);override;
         procedure writesymbol(p:pasmsymbol);override;
         procedure writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc:boolean);override;
         procedure writesymstabs(section:tsection;offset:longint;p:pchar;ps:pasmsymbol;nidx,nother,line:longint;reloc:boolean);override;
         strs,
         syms    : Tdynamicarray;
       end;

       tcoffoutput = class(tobjectoutput)
       private
         win32   : boolean;
         initsym : longint;
         procedure write_relocs(s:tobjectsection);
         procedure write_symbol(const name:string;strpos,value,section,typ,aux:longint);
         procedure write_symbols;
       protected
         procedure writetodisk;override;
       public
         constructor createdjgpp(smart:boolean);
         constructor createwin32(smart:boolean);
         function  initwriting(Aplace:tcutplace):tobjectdata;override;
       end;


implementation

    uses
{$ifdef delphi}
       sysutils,
{$else}
       strings,
{$endif}
       cutils,verbose,
       globtype,globals,fmodule;

    const
       symbolresize = 200*18;
       strsresize   = 8192;
       DataResize   = 8192;

    type
       { Structures which are written directly to the output file }
       coffheader=packed record
         mach   : word;
         nsects : word;
         time   : longint;
         sympos : longint;
         syms   : longint;
         opthdr : word;
         flag   : word;
       end;
       coffsechdr=packed record
         name     : array[0..7] of char;
         vsize    : longint;
         rvaofs   : longint;
         datasize  : longint;
         datapos  : longint;
         relocpos : longint;
         lineno1  : longint;
         nrelocs  : word;
         lineno2  : word;
         flags    : cardinal;
       end;
       coffsectionrec=packed record
         len     : longint;
         nrelocs : word;
         empty   : array[0..11] of char;
       end;
       coffreloc=packed record
         address  : longint;
         sym      : longint;
         relative : word;
       end;
       coffsymbol=packed record
         name    : array[0..3] of char; { real is [0..7], which overlaps the strpos ! }
         strpos  : longint;
         value   : longint;
         section : smallint;
         empty   : smallint;
         typ     : byte;
         aux     : byte;
       end;
       pcoffstab=^coffstab;
       coffstab=packed record
         strpos  : longint;
         ntype   : byte;
         nother  : byte;
         ndesc   : word;
         nvalue  : longint;
       end;


{****************************************************************************
                               TCoffSection
****************************************************************************}

    constructor tcoffsection.createsec(sec:TSection;AAlign,AFlags:cardinal);
      begin
        inherited create(target_asm.secnames[sec],AAlign,(sec=sec_bss));
        Flags:=AFlags;
      end;


{****************************************************************************
                                TCoffData
****************************************************************************}

    constructor tcoffdata.createdjgpp;
      begin
        inherited create;
        win32:=false;
        reset;
      end;


    constructor tcoffdata.createwin32;
      begin
        inherited create;
        win32:=true;
        reset;
      end;


    destructor tcoffdata.destroy;
      begin
        inherited destroy;
      end;


    procedure tcoffdata.reset;
      var
        s : string;
      begin
        Syms:=TDynamicArray.Create(symbolresize);
        Strs:=TDynamicArray.Create(strsresize);
        { we need at least the following 3 sections }
        createsection(sec_code);
        createsection(sec_data);
        createsection(sec_bss);
        if (cs_gdb_lineinfo in aktglobalswitches) or
           (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 tcoffdata.createsection(sec:TSection);
      var
        Flags,
        AAlign : cardinal;
      begin
        { defaults }
        Flags:=0;
        Aalign:=1;
        { alignment after section }
        case sec of
          sec_code :
            begin
              if win32 then
               Flags:=$60000020
              else
               Flags:=$20;
              Aalign:=4;
            end;
          sec_data :
            begin
              if win32 then
               Flags:=$c0300040
              else
               Flags:=$40;
              Aalign:=4;
            end;
          sec_bss :
            begin
              if win32 then
               Flags:=$c0300080
              else
               Flags:=$80;
              Aalign:=4;
            end;
          sec_idata2,
          sec_idata4,
          sec_idata5,
          sec_idata6,
          sec_idata7 :
            begin
              if win32 then
               Flags:=$40000000;
            end;
          sec_edata :
            begin
              if win32 then
               Flags:=$c0300040;
            end;
        end;
        sects[sec]:=tcoffSection.createsec(Sec,AAlign,Flags);
      end;


    procedure tcoffdata.writesymbol(p:pasmsymbol);
      var
        sym : toutputsymbol;
        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);
        FillChar(sym,sizeof(sym),0);
        sym.value:=p^.size;
        sym.bind:=p^.bind;
        sym.typ:=AT_NONE;
        { if local of global then set the section value to the address
          of the symbol }
        if sym.bind in [AB_LOCAL,AB_GLOBAL] then
         begin
           sym.section:=p^.section;
           sym.value:=p^.address+sects[sym.section].mempos;
         end;
        { store the symbol, but not the local ones }
        if (sym.bind<>AB_LOCAL) then
         begin
           { symbolname }
           s:=p^.name;
           if length(s)>8 then
            begin
              sym.nameidx:=Strs.size+4;
              Strs.writestr(s);
              Strs.writestr(#0);
            end
           else
            begin
              sym.nameidx:=-1;
              sym.namestr:=s;
            end;
           { update the asmsymbol index }
           p^.idx:=Syms.size div sizeof(TOutputSymbol);
           { write the symbol }
           Syms.write(sym,sizeof(toutputsymbol));
         end
        else
         begin
           p^.idx:=-2; { local }
         end;
      end;


    procedure tcoffdata.writereloc(data,len:longint;p:pasmsymbol;relative:relative_type);
      var
        curraddr,
        symaddr : longint;
      begin
        if not assigned(sects[currsec]) then
         createsection(currsec);
        if assigned(p) then
         begin
           { current address }
           curraddr:=sects[currsec].mempos+sects[currsec].datasize;
           { real address of the symbol }
           symaddr:=p^.address;
           if p^.section<>sec_none then
            inc(symaddr,sects[p^.section].mempos);
           { no symbol relocation need inside a section }
           if p^.section=currsec then
             begin
               case relative of
                 relative_false :
                   begin
                     sects[currsec].addsectionreloc(curraddr,currsec,relative_false);
                     inc(data,symaddr);
                   end;
                 relative_true :
                   begin
                     inc(data,symaddr-len-sects[currsec].datasize);
                   end;
                 relative_rva :
                   begin
                     sects[currsec].addsectionreloc(curraddr,currsec,relative_rva);
                     inc(data,symaddr);
                   end;
               end;
             end
           else
             begin
               writesymbol(p);
               if (p^.section<>sec_none) and (relative<>relative_true) then
                 sects[currsec].addsectionreloc(curraddr,p^.section,relative)
               else
                 sects[currsec].addsymreloc(curraddr,p,relative);
               if not win32 then {seems wrong to me (PM) }
                inc(data,symaddr)
               else
                if (relative<>relative_true) and (p^.section<>sec_none) then
                 inc(data,symaddr);
               if relative=relative_true then
                begin
                  if win32 then
                    dec(data,len-4)
                  else
                    dec(data,len+sects[currsec].datasize);
                end;
            end;
         end;
        sects[currsec].write(data,len);
      end;


    procedure tcoffdata.writestabs(section:tsection;offset:longint;p:pchar;nidx,nother,line:longint;reloc : boolean);
      var
        stab : coffstab;
        s : tsection;
        curraddr : longint;
      begin
        s:=section;
        { local var can be at offset -1 !! PM }
        if reloc then
         begin
           if (offset=-1) then
            begin
              if s=sec_none then
               offset:=0
              else
               offset:=sects[s].datasize;
            end;
           if (s<>sec_none) then
            inc(offset,sects[s].datapos);
         end;
        if assigned(p) and (p[0]<>#0) then
         begin
           stab.strpos:=sects[sec_stabstr].datasize;
           sects[sec_stabstr].write(p^,strlen(p)+1);
         end
        else
         stab.strpos:=0;
        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
         begin
           { current address }
           curraddr:=sects[sec_stab].mempos+sects[sec_stab].datasize;
           if DLLSource and RelocSection then
           { avoid relocation in the .stab section
             because it ends up in the .reloc section instead }
             sects[sec_stab].addsectionreloc(curraddr-4,s,relative_rva)
           else
             sects[sec_stab].addsectionreloc(curraddr-4,s,relative_false);
         end;
      end;


    procedure tcoffdata.writesymstabs(section:tsection;offset:longint;p:pchar;ps:pasmsymbol;
                                                 nidx,nother,line:longint;reloc:boolean);
      var
        stab : coffstab;
        curraddr : longint;
      begin
        { do not use the size stored in offset field
         this is DJGPP specific ! PM }
        if win32 then
          offset:=0;
        { local var can be at offset -1 !! PM }
        if reloc then
         begin
           if (offset=-1) then
            begin
              if section=sec_none then
               offset:=0
              else
               offset:=sects[section].datasize;
            end;
           if (section<>sec_none) then
            inc(offset,sects[section].mempos);
         end;
        if assigned(p) and (p[0]<>#0) then
         begin
           stab.strpos:=sects[sec_stabstr].datasize;
           sects[sec_stabstr].write(p^,strlen(p)+1);
         end
        else
         stab.strpos:=0;
        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
         begin
           { current address }
           curraddr:=sects[sec_stab].mempos+sects[sec_stab].datasize;
           if DLLSource and RelocSection then
            { avoid relocation in the .stab section
              because it ends up in the .reloc section instead }
            sects[sec_stab].addsymreloc(curraddr-4,ps,relative_rva)
           else
            sects[sec_stab].addsymreloc(curraddr-4,ps,relative_false);
         end;
      end;


    procedure tcoffdata.setsectionsizes(var s:tsecsize);
      var
        mempos : longint;
        sec    : tsection;
      begin
        { multiply stab with real size }
        s[sec_stab]:=s[sec_stab]*sizeof(coffstab);
        { if debug then also count header stab }
        if (cs_debuginfo in aktmoduleswitches) then
         begin
           inc(s[sec_stab],sizeof(coffstab));
           inc(s[sec_stabstr],length(SplitFileName(current_module.mainsource^))+2);
         end;
        { calc mempos }
        mempos:=0;
        for sec:=low(tsection) to high(tsection) do
         begin
           if (s[sec]>0) and
              (not assigned(sects[sec])) then
             createsection(sec);
           if assigned(sects[sec]) then
            begin
              sects[sec].memsize:=s[sec];
              { memory position }
              if not win32 then
               begin
                 sects[sec].mempos:=mempos;
                 inc(mempos,align(sects[sec].memsize,sects[sec].addralign));
               end;
            end;
         end;
      end;


{****************************************************************************
                                TCoffOutput
****************************************************************************}

    constructor tcoffoutput.createdjgpp(smart:boolean);
      begin
        inherited create(smart);
        win32:=false;
      end;


    constructor tcoffoutput.createwin32(smart:boolean);
      begin
        inherited create(smart);
        win32:=true;
      end;


    function tcoffoutput.initwriting(Aplace:tcutplace):tobjectdata;
      begin
        inherited initwriting(Aplace);
        initsym:=0;
        if win32 then
         data:=tcoffdata.createwin32
        else
         data:=tcoffdata.createdjgpp;
        initwriting:=data;
      end;


    procedure tcoffoutput.write_relocs(s:tobjectsection);
      var
        rel  : coffreloc;
        hr,r : poutputreloc;
      begin
        r:=s.relochead;
        while assigned(r) do
         begin
           rel.address:=r^.address;
           if assigned(r^.symbol) then
            begin
              if (r^.symbol^.bind=AB_LOCAL) then
               rel.sym:=2*data.sects[r^.symbol^.section].secsymidx
              else
               begin
                 if r^.symbol^.idx=-1 then
                   internalerror(4321);
                 rel.sym:=r^.symbol^.idx+initsym;
               end;
            end
           else
            begin
              if r^.section<>sec_none then
               rel.sym:=2*data.sects[r^.section].secsymidx
              else
               rel.sym:=0;
            end;
           case r^.typ 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 tcoffoutput.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 tcoffoutput.write_symbols;
      var
        filename  : string[18];
        sec       : tsection;
        sectionval,
        i         : longint;
        globalval : byte;
        secrec    : coffsectionrec;
        sym       : toutputsymbol;
      begin
        with tcoffdata(data) do
         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, also store the
             symbol index }
           for sec:=low(tsection) to high(tsection) do
            if assigned(sects[sec]) then
             begin
               write_symbol(target_asm.secnames[sec],-1,sects[sec].mempos,sects[sec].secsymidx,3,1);
               fillchar(secrec,sizeof(secrec),0);
               secrec.len:=sects[sec].aligneddatasize;
               secrec.nrelocs:=sects[sec].nrelocs;
               writer.write(secrec,sizeof(secrec));
             end;
           { The real symbols }
           Syms.seek(0);
           for i:=1 to Syms.size div sizeof(TOutputSymbol) do
            begin
              Syms.read(sym,sizeof(TOutputSymbol));
              if sym.bind=AB_LOCAL then
                globalval:=3
              else
                globalval:=2;
              if assigned(sects[sym.section]) then
               sectionval:=sects[sym.section].secsymidx
              else
               sectionval:=0;
              write_symbol(sym.namestr,sym.nameidx,sym.value,sectionval,globalval,0);
            end;
         end;
      end;


    procedure tcoffoutput.writetodisk;
      var
        datapos,
        secsymidx,
        nsects,
        sympos,i : longint;
        hstab    : coffstab;
        gotreloc : boolean;
        sec      : tsection;
        header   : coffheader;
        sechdr   : coffsechdr;
        empty    : array[0..15] of byte;
        hp       : pdynamicblock;
      begin
        with tcoffdata(data) do
         begin
         { calc amount of sections we have }
           fillchar(empty,sizeof(empty),0);
           nsects:=0;
           initsym:=2;   { 2 for the file }
           secsymidx:=0;
           for sec:=low(tsection) to high(tsection) do
            if assigned(sects[sec]) then
             begin
               inc(nsects);
               inc(secsymidx);
               sects[sec].secsymidx:=secsymidx;
               inc(initsym,2); { 2 for each section }
             end;
         { For the stab section we need an HdrSym which can now be
           calculated more easily }
           if assigned(sects[sec_stab]) then
            begin
              hstab.strpos:=1;
              hstab.ntype:=0;
              hstab.nother:=0;
              hstab.ndesc:=(sects[sec_stab].datasize div sizeof(coffstab))-1{+1 according to gas output PM};
              hstab.nvalue:=sects[sec_stabstr].datasize;
              sects[sec_stab].data.seek(0);
              sects[sec_stab].data.write(hstab,sizeof(hstab));
            end;
         { Calculate the filepositions }
           datapos:=sizeof(coffheader)+sizeof(coffsechdr)*nsects;
           { sections first }
           for sec:=low(tsection) to high(tsection) do
            if assigned(sects[sec]) then
             begin
               sects[sec].datapos:=datapos;
               if assigned(sects[sec].data) then
                 inc(datapos,sects[sec].aligneddatasize);
             end;
           { relocs }
           gotreloc:=false;
           for sec:=low(tsection) to high(tsection) do
            if assigned(sects[sec]) then
             begin
               tcoffsection(sects[sec]).relocpos:=datapos;
               inc(datapos,10*sects[sec].nrelocs);
               if (not gotreloc) and (sects[sec].nrelocs>0) then
                gotreloc:=true;
             end;
           { symbols }
           sympos:=datapos;
         { COFF header }
           fillchar(header,sizeof(coffheader),0);
           header.mach:=$14c;
           header.nsects:=nsects;
           header.sympos:=sympos;
           header.syms:=(Syms.size div sizeof(TOutputSymbol))+initsym;
           if gotreloc then
            header.flag:=$104
           else
            header.flag:=$105;
           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(target_asm.secnames[sec][1],sechdr.name,length(target_asm.secnames[sec]));
               if not win32 then
                 begin
                   sechdr.rvaofs:=sects[sec].mempos;
                   sechdr.vsize:=sects[sec].mempos;
                 end
               else
                 begin
                   if sec=sec_bss then
                     sechdr.vsize:=sects[sec].aligneddatasize;
                 end;
               sechdr.datasize:=sects[sec].aligneddatasize;
               if (sects[sec].datasize>0) and assigned(sects[sec].data) then
                 sechdr.datapos:=sects[sec].datapos;
               sechdr.nrelocs:=sects[sec].nrelocs;
               sechdr.relocpos:=TCoffSection(sects[sec]).relocpos;
               sechdr.flags:=TCoffSection(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
               sects[sec].alignsection;
               hp:=sects[sec].data.firstblock;
               while assigned(hp) do
                begin
                  writer.write(hp^.data,hp^.used);
                  hp:=hp^.next;
                end;
             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.size+4;
           writer.write(i,4);
           hp:=Strs.firstblock;
           while assigned(hp) do
            begin
              writer.write(hp^.data,hp^.used);
              hp:=hp^.next;
            end;
         end;
      end;

{****************************************************************************
                                TCoffInput
****************************************************************************}


end.
{
  $Log$
  Revision 1.8  2000-12-25 00:07:26  peter
    + new tlinkedlist class (merge of old tstringqueue,tcontainer and
      tlinkedlist objects)

  Revision 1.7  2000/12/24 12:25:31  peter
    + cstreams unit
    * dynamicarray object to class

  Revision 1.6  2000/12/23 19:59:35  peter
    * object to class for ow/og objects
    * split objectdata from objectoutput

  Revision 1.5  2000/12/21 12:06:38  jonas
    * changed type of all "flags" variables/parameters/fields to cardinal
      and removed longint typecasts around constants

  Revision 1.4  2000/12/20 15:59:04  jonas
    * fixed range check errors

  Revision 1.3  2000/12/18 21:56:35  peter
    * fixed stab reloc writing

  Revision 1.2  2000/12/07 17:19:42  jonas
    * new constant handling: from now on, hex constants >$7fffffff are
      parsed as unsigned constants (otherwise, $80000000 got sign extended
      and became $ffffffff80000000), all constants in the longint range
      become longints, all constants >$7fffffff and <=cardinal($ffffffff)
      are cardinals and the rest are int64's.
    * added lots of longint typecast to prevent range check errors in the
      compiler and rtl
    * type casts of symbolic ordinal constants are now preserved
    * fixed bug where the original resulttype wasn't restored correctly
      after doing a 64bit rangecheck

  Revision 1.1  2000/11/12 22:20:37  peter
    * create generic toutputsection for binary writers

}