fpc/compiler/ag386int.pas
1998-06-05 17:46:02 +00:00

620 lines
24 KiB
ObjectPascal

{
$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 double2str(d : double) : string;
var
hs : string;
p : byte;
begin
str(d,hs);
{ nasm expects a lowercase e }
p:=pos('E',hs);
if p>0 then
hs[p]:='e';
p:=pos('+',hs);
if p>0 then
delete(hs,p,1);
double2str:=lower(hs);
end;
function comp2str(d : bestreal) : string;
type
pdouble = ^double;
var
c : comp;
dd : pdouble;
begin
{$ifdef TP}
c:=d;
{$else}
c:=comp(d);
{$endif}
dd:=pdouble(@c); { this makes a bitwise copy of c into a double }
comp2str:=double2str(dd^);
end;
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
s:=int_reg2str[segment]+':['
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 : getopstr:=int_reg2str[tregister(o)];
top_const,
top_ref : begin
if t=top_const then
hs := tostr(longint(o))
else
hs:=getreferencestring(preference(o)^);
{ 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;
getopstr:=hs;
end;
top_symbol : begin
hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
hs:='offset '+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_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 LastSec<>sec_none then
AsmWriteLn('_'+ait_section2masmstr[LastSec]+#9#9'ENDS');
if pai_section(hp)^.sec<>sec_none then
begin
AsmLn;
AsmWriteLn('_'+ait_section2masmstr[pai_section(hp)^.sec]+#9#9+
'SEGMENT'#9'PARA PUBLIC USE32 '''+
ait_section2masmstr[pai_section(hp)^.sec]+'''');
end;
LastSec:=pai_section(hp)^.sec;
end;
ait_align : begin
{ CAUSES PROBLEMS WITH THE SEGMENT DEFINITION }
{ SEGMENT DEFINITION SHOULD MATCH TYPE OF ALIGN }
{ HERE UNDER TASM! }
AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype));
end;
ait_external : AsmWriteLn(#9'EXTRN'#9+StrPas(pai_external(hp)^.name)+
' :'+extstr[pai_external(hp)^.exttyp]);
ait_datablock : begin
if pai_datablock(hp)^.is_global then
AsmWriteLn(#9'PUBLIC'#9+StrPas(pai_datablock(hp)^.name));
AsmWriteLn(PadTabs(pai_datablock(hp)^.name,#0)+'DB'#9+tostr(pai_datablock(hp)^.size)+' DUP(?)');
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
AsmWrite(#9#9+'DD '#9'offset ');
AsmWritePChar(pchar(pai_const(hp)^.value));
AsmLn;
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 : AsmWriteLn(#9#9'DT'#9+double2str(pai_extended(hp)^.value));
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
if pai_label(hp)^.l^.is_used then
begin
AsmWrite(lab2str(pai_label(hp)^.l));
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_32bit,ait_real_64bit,ait_real_extended,ait_string])) then
AsmWriteLn(':');
end;
end;
ait_direct : begin
AsmWritePChar(pai_direct(hp)^.str);
AsmLn;
end;
ait_labeled_instruction : AsmWriteLn(#9#9+int_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab));
ait_symbol : begin
if pai_symbol(hp)^.is_global then
AsmWriteLn(#9'PUBLIC'#9+StrPas(pai_symbol(hp)^.name));
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_real_extended,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;
end
else
prefix:= '';
if pai386(hp)^.op1t<>top_none then
begin
if pai386(hp)^._operator in [A_CALL] then
begin
{ with tasm call near ptr [edi+12] does not
work but call near [edi+12] works ?? (PM)
It works with call dword ptr [], but you
need /m2 (2 passes) with tasm (PFV)
}
{ 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);}
s:='dword 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;
AsmWriteLn(#9'.386p');
AsmWriteLn(#9'LOCALS '+target_asm.labelprefix);
AsmWriteLn('DGROUP'#9'GROUP'#9'_BSS,_DATA');
AsmWriteLn(#9'ASSUME'#9'CS:_CODE,ES:DGROUP,DS:DGROUP,SS:DGROUP');
AsmLn;
WriteTree(externals);
{ INTEL ASM doesn't support stabs
WriteTree(debuglist);}
WriteTree(codesegment);
WriteTree(datasegment);
WriteTree(consts);
WriteTree(rttilist);
WriteTree(bsssegment);
AsmWriteLn(#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.11 1998-06-05 17:46:02 peter
* tp doesn't like comp() typecast
Revision 1.10 1998/05/25 17:11:36 pierre
* firstpasscount bug fixed
now all is already set correctly the first time
under EXTDEBUG try -gp to skip all other firstpasses
it works !!
* small bug fixes
- for smallsets with -dTESTSMALLSET
- some warnings removed (by correcting code !)
Revision 1.9 1998/05/23 01:20:55 peter
+ aktasmmode, aktoptprocessor, aktoutputformat
+ smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
+ $LIBNAME to set the library name where the unit will be put in
* splitted cgi386 a bit (codeseg to large for bp7)
* nasm, tasm works again. nasm moved to ag386nsm.pas
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)
}