freepascal.compiler/compiler/ag386int.pas

{
    $Id$
    Copyright (c) 1996,97 by Florian Klaempfl

    This unit implements an asmoutput class for Intel syntax with Intel i386+

    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 ag386int;

    interface

    uses aasm,assemble;

    type
      pi386intasmlist=^ti386intasmlist;
      ti386intasmlist = object(tasmlist)
        procedure WriteTree(p:paasmoutput);virtual;
        procedure WriteAsmList;virtual;
      end;

  implementation

    uses
      dos,globals,systems,cobjects,i386,
      strings,files,verbose
{$ifdef GDB}
      ,gdb
{$endif GDB}
      ;

    const
      line_length = 70;

      extstr : array[EXT_NEAR..EXT_ABS] of String[8] =
             ('NEAR','FAR','PROC','BYTE','WORD','DWORD',
              'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS');

    function getreferencestring(const ref : treference) : string;
    var
      s     : string;
      first : boolean;
    begin
      if ref.isintvalue then
       s:= tostr(ref.offset)
      else
      with ref do
        begin
          first:=true;
          if ref.segment<>R_DEFAULT_SEG then
           begin
             if current_module^.output_format in [of_nasm,of_obj] then
              s:='['+int_reg2str[segment]+':'
             else
              s:=int_reg2str[segment]+':[';
           end
          else
           s:='[';

         if assigned(symbol) then
          begin
            s:=s+symbol^;
            first:=false;
          end;
         if (base<>R_NO) then
          begin
            if not(first) then
             s:=s+'+'
            else
             first:=false;
             s:=s+int_reg2str[base];
          end;
         if (index<>R_NO) then
           begin
             if not(first) then
               s:=s+'+'
             else
               first:=false;
             s:=s+int_reg2str[index];
             if scalefactor<>0 then
               s:=s+'*'+tostr(scalefactor);
           end;
         if offset<0 then
           s:=s+tostr(offset)
         else if (offset>0) then
           s:=s+'+'+tostr(offset);
         s:=s+']';
        end;
       getreferencestring:=s;
     end;

    function getopstr(t : byte;o : pointer;s : topsize; _operator: tasmop;dest : boolean) : string;

      var
    hs : string;

      begin
    case t of
       top_reg : { a floating point register can be only a register operand }
            if current_module^.output_format in [of_nasm,of_obj] then
               getopstr:=int_nasmreg2str[tregister(o)]
            else
               getopstr:=int_reg2str[tregister(o)];
       top_const,
       top_ref : begin
                  if t=top_const then
                    hs := tostr(longint(o))
                  else
                    hs:=getreferencestring(preference(o)^);
                  if current_module^.output_format in [of_nasm,of_obj] then
                    if (_operator = A_LEA) or (_operator = A_LGS)
                    or (_operator = A_LSS) or (_operator = A_LFS)
                    or (_operator = A_LES) or (_operator = A_LDS)
                    or (_operator = A_SHR) or (_operator = A_SHL)
                    or (_operator = A_SAR) or (_operator = A_SAL)
                    or (_operator = A_OUT) or (_operator = A_IN) then
                    begin
                    end
                    else
                      case s of
                         S_B : hs:='byte '+hs;
                         S_W : hs:='word '+hs;
                         S_L : hs:='dword '+hs;
                         S_IS : hs:='word '+hs;
                         S_IL : hs:='dword '+hs;
                         S_IQ : hs:='qword '+hs;
                         S_FS : hs:='dword '+hs;
                         S_FL : hs:='qword '+hs;
                         S_FX : hs:='tword '+hs;
                         S_BW : if dest then
                             hs:='word '+hs
                           else
                             hs:='byte '+hs;
                         S_BL : if dest then
                             hs:='dword '+hs
                           else
                             hs:='byte '+hs;
                         S_WL : if dest then
                             hs:='dword '+hs
                           else
                             hs:='word '+hs;
                      end
          else
          Begin
            { can possibly give a range check error under tp }
            { if using in...                                 }
            if ((_operator <> A_LGS) and (_operator <> A_LSS) and
               (_operator <> A_LFS) and (_operator <> A_LDS) and
               (_operator <> A_LES)) then
            Begin
            case s of
               S_B : hs:='byte ptr '+hs;
               S_W : hs:='word ptr '+hs;
               S_L : hs:='dword ptr '+hs;
               S_IS : hs:='word ptr '+hs;
               S_IL : hs:='dword ptr '+hs;
               S_IQ : hs:='qword ptr '+hs;
               S_FS : hs:='dword ptr '+hs;
               S_FL : hs:='qword ptr '+hs;
               S_FX : hs:='tbyte ptr '+hs;
               S_BW : if dest then
                   hs:='word ptr '+hs
                 else
                   hs:='byte ptr '+hs;
               S_BL : if dest then
                   hs:='dword ptr '+hs
                 else
                   hs:='byte ptr '+hs;
               S_WL : if dest then
                   hs:='dword ptr '+hs
                 else
                   hs:='word ptr '+hs;
            end;
            end;
          end;
              getopstr:=hs;
            end;
       top_symbol : begin
             hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
             move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
             if current_module^.output_format=of_masm then
               hs:='offset '+hs
             else
               hs:='dword '+hs;

             if pcsymbol(o)^.offset>0 then
               hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
             else if pcsymbol(o)^.offset<0 then
               hs:=hs+tostr(pcsymbol(o)^.offset);
             getopstr:=hs;
          end;
       else internalerror(10001);
    end;
      end;

    function getopstr_jmp(t : byte;o : pointer) : string;

      var
    hs : string;

      begin
    case t of
       top_reg : getopstr_jmp:=int_reg2str[tregister(o)];
       top_ref : getopstr_jmp:=getreferencestring(preference(o)^);
       top_const : getopstr_jmp:=tostr(longint(o));
       top_symbol : begin
             hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
             move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
             if pcsymbol(o)^.offset>0 then
               hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
             else if pcsymbol(o)^.offset<0 then
               hs:=hs+tostr(pcsymbol(o)^.offset);
             getopstr_jmp:=hs;
          end;
       else internalerror(10001);
    end;
      end;

{****************************************************************************
                               TI386INTASMLIST
 ****************************************************************************}

    var
      LastSec : tsection;


    const
      ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]=
        (#9'DD'#9,'',#9'DW'#9,#9'DB'#9);

      ait_section2nasmstr : array[tsection] of string[6]=
       ('','.text','.data','.bss','.idata');

      ait_section2masmstr : array[tsection] of string[6]=
       ('','CODE','DATA','BSS','');


    Function PadTabs(p:pchar;addch:char):string;
    var
      s : string;
      i : longint;
    begin
      i:=strlen(p);
      if addch<>#0 then
       begin
         inc(i);
         s:=StrPas(p)+addch;
       end
      else
       s:=StrPas(p);
      if i<8 then
       PadTabs:=s+#9#9
      else
       PadTabs:=s+#9;
    end;

    procedure ti386intasmlist.WriteTree(p:paasmoutput);
    type
      twowords=record
        word1,word2:word;
      end;
    var
      s,
      prefix,
      suffix   : string;
      hp       : pai;
      counter,
      lines,
      i,j,l    : longint;
      consttyp : tait;
      found,
      quoted   : boolean;
    begin
      if not assigned(p) then
       exit;
      hp:=pai(p^.first);
      while assigned(hp) do
       begin
         case hp^.typ of
       ait_comment : Begin
                       AsmWrite(target_asm.comment);
                       AsmWritePChar(pai_asm_comment(hp)^.str);
                       AsmLn;
                     End;
       ait_section : begin
                       if current_module^.output_format in [of_nasm,of_obj] then
                         AsmWriteLn('SECTION '+ait_section2nasmstr[pai_section(hp)^.sec])
                       else


                         begin
                           if LastSec<>sec_none then
                             AsmWriteLn('_'+ait_section2masmstr[LastSec]+#9#9'ENDS');
                           AsmWriteLn('_'+ait_section2masmstr[pai_section(hp)^.sec]+'DATA'#9#9+
                             'SEGMENT'#9'PARA PUBLIC USE32 '''+ait_section2masmstr[pai_section(hp)^.sec]+'''');
                         end;

                       LastSec:=pai_section(hp)^.sec;
                     end;
         ait_align : begin
                     { align not supported at all with nasm v095  }
                     { align with specific value not supported by }
                     { turbo assembler.                           }
                     { CAUSES PROBLEMS WITH THE SEGMENT DEFINITION   }
                     { SEGMENT DEFINITION SHOULD MATCH TYPE OF ALIGN }
                     { HERE UNDER TASM!                              }
                     { if current_module^.output_format<>of_nasm then }
                        AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype));
                     end;
      ait_external : begin
                       if current_module^.output_format in [of_nasm,of_obj] then
                        AsmWriteLn('EXTERN '+StrPas(pai_external(hp)^.name))
                       else
                        AsmWriteLn(#9#9'EXTRN'#9+StrPas(pai_external(hp)^.name)+
                                   ' :'+extstr[pai_external(hp)^.exttyp]);
                     end;
     ait_datablock : begin
                       if current_module^.output_format in [of_nasm,of_obj] then
                        begin
                          if pai_datablock(hp)^.is_global then
                           AsmWriteLn('GLOBAL '+StrPas(pai_datablock(hp)^.name));
                          AsmWriteLn(PadTabs(pai_datablock(hp)^.name,':')+'RESB'#9+tostr(pai_datablock(hp)^.size));
                        end
                       else
                        begin
                          if pai_datablock(hp)^.is_global then
                           AsmWriteLn(#9#9'PUBLIC'#9+StrPas(pai_datablock(hp)^.name));
                          AsmWriteLn(PadTabs(pai_datablock(hp)^.name,#0)+'DB'#9+tostr(pai_datablock(hp)^.size)+' DUP(?)');
                        end;
                     end;
   ait_const_32bit,
    ait_const_8bit,
   ait_const_16bit : begin
                       AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value));
                       consttyp:=hp^.typ;
                       l:=0;
                       repeat
                         found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp);
                         if found then
                          begin
                            hp:=Pai(hp^.next);
                            s:=','+tostr(pai_const(hp)^.value);
                            AsmWrite(s);
                            inc(l,length(s));
                          end;
                       until (not found) or (l>line_length);
                       AsmLn;
                     end;
  ait_const_symbol : begin
                       if current_module^.output_format<>of_nasm then
                        AsmWrite(#9#9+'DD '#9'offset ')
                       else
                        AsmWrite(#9#9+'DD '#9);
                       AsmWriteLn(StrPas(pchar(pai_const(hp)^.value)));
                     end;
    ait_real_32bit : AsmWriteLn(#9#9'DD'#9+double2str(pai_single(hp)^.value));
    ait_real_64bit : AsmWriteLn(#9#9'DQ'#9+double2str(pai_double(hp)^.value));
 ait_real_extended : begin
                     { nasm v095 does not like DT with real constants }
                     { therefore write as double.                     }
                     { other possible solution: decode directly to hex}
                     { value.                                         }
                       if current_module^.output_format<>of_nasm then
                        AsmWriteLn(#9#9'DT'#9+double2str(pai_extended(hp)^.value))
                       else
                        begin
{$ifdef EXTDEBUG}
                          AsmLn;
                          AsmWriteLn('; NASM bug work around for extended real');
{$endif}
                          AsmWriteLn(#9#9'DD'#9+double2str(pai_extended(hp)^.value))
                        end;
                     end;
          ait_comp : AsmWriteLn(#9#9'DQ'#9+comp2str(pai_extended(hp)^.value));
        ait_string : begin
                       counter := 0;
                       lines := pai_string(hp)^.len div line_length;
                     { separate lines in different parts }
                       if pai_string(hp)^.len > 0 then
                        Begin
                          for j := 0 to lines-1 do
                           begin
                             AsmWrite(#9#9'DB'#9);
                             quoted:=false;
                             for i:=counter to counter+line_length do
                                begin
                                  { it is an ascii character. }
                                  if (ord(pai_string(hp)^.str[i])>31) and
                                     (ord(pai_string(hp)^.str[i])<128) and
                                     (pai_string(hp)^.str[i]<>'"') then
                                      begin
                                        if not(quoted) then
                                            begin
                                              if i>counter then
                                                AsmWrite(',');
                                              AsmWrite('"');
                                            end;
                                        AsmWrite(pai_string(hp)^.str[i]);
                                        quoted:=true;
                                      end { if > 31 and < 128 and ord('"') }
                                  else
                                      begin
                                          if quoted then
                                              AsmWrite('"');
                                          if i>counter then
                                              AsmWrite(',');
                                          quoted:=false;
                                          AsmWrite(tostr(ord(pai_string(hp)^.str[i])));
                                      end;
                               end; { end for i:=0 to... }
                             if quoted then AsmWrite('"');
                               AsmWrite(target_os.newline);
                             counter := counter+line_length;
                          end; { end for j:=0 ... }
                        { do last line of lines }
                        AsmWrite(#9#9'DB'#9);
                        quoted:=false;
                        for i:=counter to pai_string(hp)^.len-1 do
                          begin
                            { it is an ascii character. }
                            if (ord(pai_string(hp)^.str[i])>31) and
                               (ord(pai_string(hp)^.str[i])<128) and
                               (pai_string(hp)^.str[i]<>'"') then
                                begin
                                  if not(quoted) then
                                      begin
                                        if i>counter then
                                          AsmWrite(',');
                                        AsmWrite('"');
                                      end;
                                  AsmWrite(pai_string(hp)^.str[i]);
                                  quoted:=true;
                                end { if > 31 and < 128 and " }
                            else
                                begin
                                  if quoted then
                                    AsmWrite('"');
                                  if i>counter then
                                      AsmWrite(',');
                                  quoted:=false;
                                  AsmWrite(tostr(ord(pai_string(hp)^.str[i])));
                                end;
                          end; { end for i:=0 to... }
                        if quoted then
                          AsmWrite('"');
                        end;
                       AsmLn;
                     end;
         ait_label : begin
                       AsmWrite(lab2str(pai_label(hp)^.l));
                       if (current_module^.output_format in [of_obj,of_nasm]) or
                          (assigned(hp^.next) and not(pai(hp^.next)^.typ in
                           [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
                            ait_real_32bit,ait_real_64bit,ait_real_extended,ait_string])) then
                        AsmWriteLn(':');
                     end;
        ait_direct : begin
                       AsmWritePChar(pai_direct(hp)^.str);
                       AsmLn;
                     end;
ait_labeled_instruction :
                     begin
                       if (current_module^.output_format in [of_nasm,of_obj]) and
                          not (pai_labeled(hp)^._operator in [A_JMP,A_LOOP,A_LOOPZ,A_LOOPE,
                          A_LOOPNZ,A_LOOPNE,A_JCXZ,A_JECXZ]) then
                        AsmWriteLn(#9#9+int_op2str[pai_labeled(hp)^._operator]+#9+'near '+lab2str(pai_labeled(hp)^.lab))
                       else
                        AsmWriteLn(#9#9+int_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab));
                     end;
        ait_symbol : begin
                       if pai_symbol(hp)^.is_global then
                        begin
                          if current_module^.output_format in [of_nasm,of_obj] then
                           AsmWriteLn('GLOBAL '+StrPas(pai_symbol(hp)^.name))
                          else
                           AsmWriteLn(#9#9'PUBLIC'#9+StrPas(pai_symbol(hp)^.name));
                        end;
                       AsmWritePChar(pai_symbol(hp)^.name);
                       if assigned(hp^.next) and not(pai(hp^.next)^.typ in
                        [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
                         ait_real_64bit,ait_string]) then
                        AsmWriteLn(':')
                     end;
   ait_instruction : begin
                       suffix:='';
                       prefix:= '';
                     { added prefix instructions, must be on same line as opcode }
                       if (pai386(hp)^.op1t = top_none) and
                          ((pai386(hp)^._operator = A_REP) or
                           (pai386(hp)^._operator = A_LOCK) or
                           (pai386(hp)^._operator =  A_REPE) or
                           (pai386(hp)^._operator = A_REPNE)) then
                        Begin
                          prefix:=int_op2str[pai386(hp)^._operator]+#9;
                          hp:=Pai(hp^.next);
                        { this is theorically impossible... }
                          if hp=nil then
                           begin
                             s:=#9#9+prefix;
                             AsmWriteLn(s);
                             break;
                           end;
                          { nasm prefers prefix on a line alone }
                          if (current_module^.output_format in [of_nasm,of_obj]) then
                            begin
                               AsmWriteln(#9#9+prefix);
                               prefix:='';
                            end;
                        end
                       else
                        prefix:= '';
                       { A_FNSTS need the w as suffix at least for nasm}
                       if (current_module^.output_format in [of_nasm,of_obj]) then
                         if (pai386(hp)^._operator = A_FNSTS) then
                           pai386(hp)^._operator:=A_FNSTSW
                         else if (pai386(hp)^._operator = A_FSTS) then
                           pai386(hp)^._operator:=A_FSTSW;
                       if pai386(hp)^.op1t<>top_none then
                        begin
                          if pai386(hp)^._operator in [A_CALL] then
                           begin
                             if output_format=of_nasm then
                              s:=getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1)
                              { with tasm call near ptr [edi+12] does not
                                work but call near [edi+12] works ?? (PM)}
                             else if pai386(hp)^.op1t=top_ref then
                                s:='near '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1)
                             else
                                s:='near ptr '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1);
                           end
                          else
                           begin
                             s:=getopstr(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.size,pai386(hp)^._operator,false);
                             if pai386(hp)^.op3t<>top_none then
                              begin
                                if pai386(hp)^.op2t<>top_none then
                                 s:=getopstr(pai386(hp)^.op2t,pointer(longint(twowords(pai386(hp)^.op2).word1)),
                                             pai386(hp)^.size,pai386(hp)^._operator,true)+','+s;
                                          s:=getopstr(pai386(hp)^.op3t,pointer(longint(twowords(pai386(hp)^.op2).word2)),
                                           pai386(hp)^.size,pai386(hp)^._operator,false)+','+s;
                              end
                             else
                              if pai386(hp)^.op2t<>top_none then
                               s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,pai386(hp)^.size,
                                           pai386(hp)^._operator,true)+','+s;
                           end;
                          s:=#9+s;
                        end
                       else
                        begin
                          { check if string instruction }
                          { long form, otherwise may give range check errors }
                          { in turbo pascal...                               }
                          if ((pai386(hp)^._operator = A_CMPS) or
                             (pai386(hp)^._operator = A_INS) or
                             (pai386(hp)^._operator = A_OUTS) or
                             (pai386(hp)^._operator = A_SCAS) or
                             (pai386(hp)^._operator = A_STOS) or
                             (pai386(hp)^._operator = A_MOVS) or
                             (pai386(hp)^._operator = A_LODS) or
                             (pai386(hp)^._operator = A_XLAT)) then
                           Begin
                             case pai386(hp)^.size of
                              S_B: suffix:='b';
                              S_W: suffix:='w';
                              S_L: suffix:='d';
                             else
                              Message(assem_f_invalid_suffix_intel);
                             end;
                           end;
                          s:='';
                        end;
                       AsmWriteLn(#9#9+prefix+int_op2str[pai386(hp)^._operator]+suffix+s);
                     end;
{$ifdef GDB}
             ait_stabn,
             ait_stabs,
ait_stab_function_name : ;
{$endif GDB}
         else
          internalerror(10000);
         end;
         hp:=pai(hp^.next);
       end;
    end;


    procedure ti386intasmlist.WriteAsmList;

    begin
{$ifdef EXTDEBUG}
      if assigned(current_module^.mainsource) then
       comment(v_info,'Start writing intel-styled assembler output for '+current_module^.mainsource^);
{$endif}
      LastSec:=sec_none;
      if current_module^.output_format in [of_nasm,of_obj] then
       AsmWriteLn('BITS 32')
      else
       begin
         AsmWriteLn(#9'.386p');
         AsmWriteLn(#9'LOCALS '+target_asm.labelprefix);
         AsmWriteLn('DGROUP'#9#9'GROUP'#9'_BSS,_DATA');
         AsmWriteLn(#9#9'ASSUME'#9'CS:_TEXT,ES:DGROUP,DS:DGROUP,SS:DGROUP');
       end;



      WriteTree(externals);
    { INTEL ASM doesn't support stabs
      WriteTree(debuglist);}

      WriteTree(codesegment);
      WriteTree(datasegment);
      WriteTree(consts);
      WriteTree(rttilist);
      WriteTree(bsssegment);

      if not (current_module^.output_format in [of_nasm,of_obj]) then
       AsmWriteLn(#9#9'END');


      AsmLn;

{$ifdef EXTDEBUG}
      if assigned(current_module^.mainsource) then
       comment(v_info,'Done writing intel-styled assembler output for '+current_module^.mainsource^);
{$endif EXTDEBUG}
   end;

end.
{
  $Log$
  Revision 1.8  1998-05-06 18:36:53  peter
    * tai_section extended with code,data,bss sections and enumerated type
    * ident 'compiled by FPC' moved to pmodules
    * small fix for smartlink

  Revision 1.7  1998/05/06 08:38:32  pierre
    * better position info with UseTokenInfo
      UseTokenInfo greatly simplified
    + added check for changed tree after first time firstpass
      (if we could remove all the cases were it happen
      we could skip all firstpass if firstpasscount > 1)
      Only with ExtDebug

  Revision 1.6  1998/05/04 17:54:24  peter
    + smartlinking works (only case jumptable left todo)
    * redesign of systems.pas to support assemblers and linkers
    + Unitname is now also in the PPU-file, increased version to 14

  Revision 1.5  1998/05/01 07:43:52  florian
    + basics for rtti implemented
    + switch $m (generate rtti for published sections)

  Revision 1.4  1998/04/29 10:33:41  pierre
    + added some code for ansistring (not complete nor working yet)
    * corrected operator overloading
    * corrected nasm output
    + started inline procedures
    + added starstarn : use ** for exponentiation (^ gave problems)
    + started UseTokenInfo cond to get accurate positions

  Revision 1.3  1998/04/08 16:58:01  pierre
    * several bugfixes
      ADD ADC and AND are also sign extended
      nasm output OK (program still crashes at end
      and creates wrong assembler files !!)
      procsym types sym in tdef removed !!

  Revision 1.2  1998/04/08 11:34:17  peter
    * nasm works (linux only tested)
}