paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-27 08:53:42 +02:00
Code Issues Packages Projects Releases Wiki Activity
796234f596
fpc/compiler/cgai386.pas
florian 796234f596 * fixed bug #292 from bugs directory
1999-09-29 11:46:18 +00:00

4215 lines
156 KiB
ObjectPascal
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
Helper routines for the i386 code generator
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 cgai386;
interface
uses
cobjects,tree,
cpubase,cpuasm,
symconst,symtable,aasm,win_targ;
{$define TESTGETTEMP to store const that
are written into temps for later release PM }
function def_opsize(p1:pdef):topsize;
function def2def_opsize(p1,p2:pdef):topsize;
function def_getreg(p1:pdef):tregister;
function makereg8(r:tregister):tregister;
function makereg16(r:tregister):tregister;
function makereg32(r:tregister):tregister;
procedure emitlab(var l : pasmlabel);
procedure emitjmp(c : tasmcond;var l : pasmlabel);
procedure emit_flag2reg(flag:tresflags;hregister:tregister);
procedure emit_none(i : tasmop;s : topsize);
procedure emit_const(i : tasmop;s : topsize;c : longint);
procedure emit_reg(i : tasmop;s : topsize;reg : tregister);
procedure emit_ref(i : tasmop;s : topsize;ref : preference);
procedure emit_const_reg(i : tasmop;s : topsize;c : longint;reg : tregister);
procedure emit_const_ref(i : tasmop;s : topsize;c : longint;ref : preference);
procedure emit_ref_reg(i : tasmop;s : topsize;ref : preference;reg : tregister);
procedure emit_reg_ref(i : tasmop;s : topsize;reg : tregister;ref : preference);
procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
procedure emit_const_reg_reg(i : tasmop;s : topsize;c : longint;reg1,reg2 : tregister);
procedure emit_reg_reg_reg(i : tasmop;s : topsize;reg1,reg2,reg3 : tregister);
procedure emit_sym(i : tasmop;s : topsize;op : pasmsymbol);
procedure emit_sym_ofs(i : tasmop;s : topsize;op : pasmsymbol;ofs : longint);
procedure emit_sym_ofs_reg(i : tasmop;s : topsize;op : pasmsymbol;ofs:longint;reg : tregister);
procedure emit_sym_ofs_ref(i : tasmop;s : topsize;op : pasmsymbol;ofs:longint;ref : preference);
procedure emitcall(const routine:string);
procedure emit_mov_loc_ref(const t:tlocation;const ref:treference;siz:topsize);
procedure emit_mov_loc_reg(const t:tlocation;reg:tregister);
procedure emit_lea_loc_ref(const t:tlocation;const ref:treference;freetemp:boolean);
procedure emit_lea_loc_reg(const t:tlocation;reg:tregister;freetemp:boolean);
procedure emit_push_loc(const t:tlocation);
{ pushes qword location to the stack }
procedure emit_pushq_loc(const t : tlocation);
procedure release_qword_loc(const t : tlocation);
{ releases the registers of a location }
procedure release_loc(const t : tlocation);
procedure emit_pushw_loc(const t:tlocation);
procedure emit_push_lea_loc(const t:tlocation;freetemp:boolean);
procedure emit_to_mem(var p:ptree);
procedure emit_to_reg16(var hr:tregister);
procedure emit_to_reg32(var hr:tregister);
procedure emit_mov_reg_loc(reg: TRegister; const t:tlocation);
procedure emit_movq_reg_loc(reghigh,reglow: TRegister;t:tlocation);
procedure copyshortstring(const dref,sref : treference;len : byte;loadref:boolean);
procedure loadansistring(p : ptree);
procedure finalize(t : pdef;const ref : treference;is_already_ref : boolean);
procedure decrstringref(t : pdef;const ref : treference);
function maybe_push(needed : byte;p : ptree;isint64 : boolean) : boolean;
procedure push_int(l : longint);
procedure emit_push_mem(const ref : treference);
procedure emitpushreferenceaddr(const ref : treference);
procedure pushsetelement(p : ptree);
procedure restore(p : ptree;isint64 : boolean);
procedure push_value_para(p:ptree;inlined:boolean;para_offset:longint;alignment : longint);
{$ifdef TEMPS_NOT_PUSH}
{ does the same as restore/ , but uses temp. space instead of pushing }
function maybe_push(needed : byte;p : ptree;isint64 : boolean) : boolean;
procedure restorefromtemp(p : ptree;isint64 : boolean);
{$endif TEMPS_NOT_PUSH}
procedure floatload(t : tfloattype;const ref : treference);
procedure floatstore(t : tfloattype;const ref : treference);
procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize);
procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize);
procedure maybe_loadesi;
procedure maketojumpbool(p : ptree);
procedure emitloadord2reg(const location:Tlocation;orddef:Porddef;destreg:Tregister;delloc:boolean);
procedure emitoverflowcheck(p:ptree);
procedure emitrangecheck(p:ptree;todef:pdef);
procedure concatcopy(source,dest : treference;size : longint;delsource : boolean;loadref:boolean);
procedure firstcomplex(p : ptree);
procedure genentrycode(alist : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean;
stackframe:longint;
var parasize:longint;var nostackframe:boolean;
inlined : boolean);
procedure genexitcode(alist : paasmoutput;parasize:longint;
nostackframe,inlined:boolean);
{$ifdef test_dest_loc}
const
{ used to avoid temporary assignments }
dest_loc_known : boolean = false;
in_dest_loc : boolean = false;
dest_loc_tree : ptree = nil;
var
dest_loc : tlocation;
procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{$endif test_dest_loc}
implementation
uses
strings,globtype,systems,globals,verbose,files,types,pbase,
tgeni386,temp_gen,hcodegen,ppu
{$ifdef GDB}
,gdb
{$endif}
;
{*****************************************************************************
Helpers
*****************************************************************************}
function def_opsize(p1:pdef):topsize;
begin
case p1^.size of
1 : def_opsize:=S_B;
2 : def_opsize:=S_W;
4 : def_opsize:=S_L;
else
internalerror(78);
end;
end;
function def2def_opsize(p1,p2:pdef):topsize;
var
o1 : topsize;
begin
case p1^.size of
1 : o1:=S_B;
2 : o1:=S_W;
4 : o1:=S_L;
{ I don't know if we need it (FK) }
8 : o1:=S_L;
else
internalerror(78);
end;
if assigned(p2) then
begin
case p2^.size of
1 : o1:=S_B;
2 : begin
if o1=S_B then
o1:=S_BW
else
o1:=S_W;
end;
4,8:
begin
case o1 of
S_B : o1:=S_BL;
S_W : o1:=S_WL;
end;
end;
end;
end;
def2def_opsize:=o1;
end;
function def_getreg(p1:pdef):tregister;
begin
case p1^.size of
1 : def_getreg:=reg32toreg8(getregister32);
2 : def_getreg:=reg32toreg16(getregister32);
4 : def_getreg:=getregister32;
else
internalerror(78);
end;
end;
function makereg8(r:tregister):tregister;
begin
case r of
R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP :
makereg8:=reg32toreg8(r);
R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP :
makereg8:=reg16toreg8(r);
R_AL,R_BL,R_CL,R_DL :
makereg8:=r;
end;
end;
function makereg16(r:tregister):tregister;
begin
case r of
R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP :
makereg16:=reg32toreg16(r);
R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP :
makereg16:=r;
R_AL,R_BL,R_CL,R_DL :
makereg16:=reg8toreg16(r);
end;
end;
function makereg32(r:tregister):tregister;
begin
case r of
R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP :
makereg32:=r;
R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP :
makereg32:=reg16toreg32(r);
R_AL,R_BL,R_CL,R_DL :
makereg32:=reg8toreg32(r);
end;
end;
{*****************************************************************************
Emit Assembler
*****************************************************************************}
procedure emitlab(var l : pasmlabel);
begin
if not l^.is_set then
exprasmlist^.concat(new(pai_label,init(l)))
else
internalerror(7453984);
end;
{$ifdef nojmpfix}
procedure emitjmp(c : tasmcond;var l : pasmlabel);
var
ai : Paicpu;
begin
if c=C_None then
exprasmlist^.concat(new(paicpu,op_sym(A_JMP,S_NO,l)))
else
begin
ai:=new(paicpu,op_sym(A_Jcc,S_NO,l));
ai^.SetCondition(c);
ai^.is_jmp:=true;
exprasmlist^.concat(ai);
end;
end;
{$else nojmpfix}
procedure emitjmp(c : tasmcond;var l : pasmlabel);
var
ai : Paicpu;
begin
if c=C_None then
ai := new(paicpu,op_sym(A_JMP,S_NO,l))
else
begin
ai:=new(paicpu,op_sym(A_Jcc,S_NO,l));
ai^.SetCondition(c);
end;
ai^.is_jmp:=true;
exprasmlist^.concat(ai);
end;
{$endif nojmpfix}
procedure emit_flag2reg(flag:tresflags;hregister:tregister);
var
ai : paicpu;
hreg : tregister;
begin
hreg:=makereg8(hregister);
ai:=new(paicpu,op_reg(A_Setcc,S_B,hreg));
ai^.SetCondition(flag_2_cond[flag]);
exprasmlist^.concat(ai);
if hreg<>hregister then
begin
if hregister in regset16bit then
emit_to_reg16(hreg)
else
emit_to_reg32(hreg);
end;
end;
procedure emit_none(i : tasmop;s : topsize);
begin
exprasmlist^.concat(new(paicpu,op_none(i,s)));
end;
procedure emit_reg(i : tasmop;s : topsize;reg : tregister);
begin
exprasmlist^.concat(new(paicpu,op_reg(i,s,reg)));
end;
procedure emit_ref(i : tasmop;s : topsize;ref : preference);
begin
exprasmlist^.concat(new(paicpu,op_ref(i,s,ref)));
end;
procedure emit_const(i : tasmop;s : topsize;c : longint);
begin
exprasmlist^.concat(new(paicpu,op_const(i,s,c)));
end;
procedure emit_const_reg(i : tasmop;s : topsize;c : longint;reg : tregister);
begin
exprasmlist^.concat(new(paicpu,op_const_reg(i,s,c,reg)));
end;
procedure emit_const_ref(i : tasmop;s : topsize;c : longint;ref : preference);
begin
exprasmlist^.concat(new(paicpu,op_const_ref(i,s,c,ref)));
end;
procedure emit_ref_reg(i : tasmop;s : topsize;ref : preference;reg : tregister);
begin
exprasmlist^.concat(new(paicpu,op_ref_reg(i,s,ref,reg)));
end;
procedure emit_reg_ref(i : tasmop;s : topsize;reg : tregister;ref : preference);
begin
exprasmlist^.concat(new(paicpu,op_reg_ref(i,s,reg,ref)));
end;
procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
begin
if (reg1<>reg2) or (i<>A_MOV) then
exprasmlist^.concat(new(paicpu,op_reg_reg(i,s,reg1,reg2)));
end;
procedure emit_const_reg_reg(i : tasmop;s : topsize;c : longint;reg1,reg2 : tregister);
begin
exprasmlist^.concat(new(paicpu,op_const_reg_reg(i,s,c,reg1,reg2)));
end;
procedure emit_reg_reg_reg(i : tasmop;s : topsize;reg1,reg2,reg3 : tregister);
begin
exprasmlist^.concat(new(paicpu,op_reg_reg_reg(i,s,reg1,reg2,reg3)));
end;
procedure emit_sym(i : tasmop;s : topsize;op : pasmsymbol);
begin
exprasmlist^.concat(new(paicpu,op_sym(i,s,op)));
end;
procedure emit_sym_ofs(i : tasmop;s : topsize;op : pasmsymbol;ofs : longint);
begin
exprasmlist^.concat(new(paicpu,op_sym_ofs(i,s,op,ofs)));
end;
procedure emit_sym_ofs_reg(i : tasmop;s : topsize;op : pasmsymbol;ofs:longint;reg : tregister);
begin
exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(i,s,op,ofs,reg)));
end;
procedure emit_sym_ofs_ref(i : tasmop;s : topsize;op : pasmsymbol;ofs:longint;ref : preference);
begin
exprasmlist^.concat(new(paicpu,op_sym_ofs_ref(i,s,op,ofs,ref)));
end;
procedure emitcall(const routine:string);
begin
exprasmlist^.concat(new(paicpu,op_sym(A_CALL,S_NO,newasmsymbol(routine))));
end;
{ only usefull in startup code }
procedure emitinsertcall(const routine:string);
begin
exprasmlist^.insert(new(paicpu,op_sym(A_CALL,S_NO,newasmsymbol(routine))));
end;
procedure emit_mov_loc_ref(const t:tlocation;const ref:treference;siz:topsize);
var
hreg : tregister;
pushedeax : boolean;
begin
pushedeax:=false;
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,siz,
t.register,newreference(ref))));
ungetregister32(t.register); { the register is not needed anymore }
end;
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.is_immediate then
emit_const_ref(A_MOV,siz,
t.reference.offset,newreference(ref))
else
begin
case siz of
S_B : begin
{ we can't do a getregister in the code generator }
{ without problems!!! }
if usablereg32>0 then
hreg:=reg32toreg8(getregister32)
else
begin
emit_reg(A_PUSH,S_L,R_EAX);
pushedeax:=true;
hreg:=R_AL;
end;
end;
S_W : hreg:=R_DI;
S_L : hreg:=R_EDI;
end;
emit_ref_reg(A_MOV,siz,
newreference(t.reference),hreg);
del_reference(t.reference);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,siz,
hreg,newreference(ref))));
if siz=S_B then
begin
if pushedeax then
emit_reg(A_POP,S_L,R_EAX)
else
ungetregister(hreg);
end;
{ we can release the registers }
{ but only AFTER the MOV! Important for the optimizer!
(JM)}
del_reference(ref);
end;
ungetiftemp(t.reference);
end;
else
internalerror(330);
end;
end;
procedure emit_mov_loc_reg(const t:tlocation;reg:tregister);
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
emit_reg_reg(A_MOV,S_L,t.register,reg);
ungetregister32(t.register); { the register is not needed anymore }
end;
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.is_immediate then
emit_const_reg(A_MOV,S_L,
t.reference.offset,reg)
else
begin
emit_ref_reg(A_MOV,S_L,
newreference(t.reference),reg);
end;
end;
else
internalerror(330);
end;
end;
procedure emit_mov_reg_loc(reg: TRegister; const t:tlocation);
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
emit_reg_reg(A_MOV,RegSize(Reg),
reg,t.register);
end;
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.is_immediate then
internalerror(334)
else
begin
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,RegSize(Reg),
Reg,newreference(t.reference))));
end;
end;
else
internalerror(330);
end;
end;
procedure emit_lea_loc_reg(const t:tlocation;reg:tregister;freetemp:boolean);
begin
case t.loc of
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.is_immediate then
internalerror(331)
else
begin
emit_ref_reg(A_LEA,S_L,
newreference(t.reference),reg);
end;
if freetemp then
ungetiftemp(t.reference);
end;
else
internalerror(332);
end;
end;
procedure emit_movq_reg_loc(reghigh,reglow: TRegister;t:tlocation);
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
emit_reg_reg(A_MOV,S_L,
reglow,t.registerlow);
emit_reg_reg(A_MOV,S_L,
reghigh,t.registerhigh);
end;
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.is_immediate then
internalerror(334)
else
begin
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,
Reglow,newreference(t.reference))));
inc(t.reference.offset,4);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,
Reghigh,newreference(t.reference))));
end;
end;
else
internalerror(330);
end;
end;
procedure emit_pushq_loc(const t : tlocation);
var
hr : preference;
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,
t.registerhigh)));
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,
t.registerlow)));
end;
LOC_MEM,
LOC_REFERENCE:
begin
hr:=newreference(t.reference);
inc(hr^.offset,4);
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,
hr)));
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,
newreference(t.reference))));
ungetiftemp(t.reference);
end;
else internalerror(331);
end;
end;
procedure release_loc(const t : tlocation);
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
ungetregister32(t.register);
end;
LOC_MEM,
LOC_REFERENCE:
del_reference(t.reference);
else internalerror(332);
end;
end;
procedure release_qword_loc(const t : tlocation);
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
ungetregister32(t.registerhigh);
ungetregister32(t.registerlow);
end;
LOC_MEM,
LOC_REFERENCE:
del_reference(t.reference);
else internalerror(331);
end;
end;
procedure emit_push_loc(const t:tlocation);
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,makereg32(t.register))));
ungetregister(t.register); { the register is not needed anymore }
end;
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.is_immediate then
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,t.reference.offset)))
else
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,newreference(t.reference))));
del_reference(t.reference);
ungetiftemp(t.reference);
end;
else
internalerror(330);
end;
end;
procedure emit_pushw_loc(const t:tlocation);
var
opsize : topsize;
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
if target_os.stackalignment=4 then
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,makereg32(t.register))))
else
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_W,makereg16(t.register))));
ungetregister(t.register); { the register is not needed anymore }
end;
LOC_MEM,
LOC_REFERENCE : begin
if target_os.stackalignment=4 then
opsize:=S_L
else
opsize:=S_W;
if t.reference.is_immediate then
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,opsize,t.reference.offset)))
else
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,opsize,newreference(t.reference))));
del_reference(t.reference);
ungetiftemp(t.reference);
end;
else
internalerror(330);
end;
end;
procedure emit_lea_loc_ref(const t:tlocation;const ref:treference;freetemp:boolean);
begin
case t.loc of
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.is_immediate then
internalerror(331)
else
begin
emit_ref_reg(A_LEA,S_L,
newreference(t.reference),R_EDI);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,
R_EDI,newreference(ref))));
end;
{ release the registers }
del_reference(t.reference);
if freetemp then
ungetiftemp(t.reference);
end;
else
internalerror(332);
end;
end;
procedure emit_push_lea_loc(const t:tlocation;freetemp:boolean);
begin
case t.loc of
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.is_immediate then
internalerror(331)
else
begin
emit_ref_reg(A_LEA,S_L,
newreference(t.reference),R_EDI);
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI)));
end;
if freetemp then
ungetiftemp(t.reference);
end;
else
internalerror(332);
end;
end;
procedure emit_to_mem(var p:ptree);
begin
case p^.location.loc of
LOC_FPU : begin
reset_reference(p^.location.reference);
gettempofsizereference(10,p^.location.reference);
floatstore(pfloatdef(p^.resulttype)^.typ,p^.location.reference);
{ This can't be never a l-value! (FK)
p^.location.loc:=LOC_REFERENCE; }
end;
LOC_MEM,
LOC_REFERENCE : ;
LOC_CFPUREGISTER : begin
emit_reg(A_FLD,S_NO,correct_fpuregister(p^.location.register,fpuvaroffset));
inc(fpuvaroffset);
reset_reference(p^.location.reference);
gettempofsizereference(10,p^.location.reference);
floatstore(pfloatdef(p^.resulttype)^.typ,p^.location.reference);
{ This can't be never a l-value! (FK)
p^.location.loc:=LOC_REFERENCE; }
end;
else
internalerror(333);
end;
p^.location.loc:=LOC_MEM;
end;
procedure emit_to_reg16(var hr:tregister);
begin
{ ranges are a little bit bug sensitive ! }
case hr of
R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP,R_EBP:
begin
hr:=reg32toreg16(hr);
end;
R_AL,R_BL,R_CL,R_DL:
begin
hr:=reg8toreg16(hr);
emit_const_reg(A_AND,S_W,$ff,hr);
end;
R_AH,R_BH,R_CH,R_DH:
begin
hr:=reg8toreg16(hr);
emit_const_reg(A_AND,S_W,$ff00,hr);
end;
end;
end;
procedure emit_to_reg32(var hr:tregister);
begin
{ ranges are a little bit bug sensitive ! }
case hr of
R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP,R_BP:
begin
hr:=reg16toreg32(hr);
emit_const_reg(A_AND,S_L,$ffff,hr);
end;
R_AL,R_BL,R_CL,R_DL:
begin
hr:=reg8toreg32(hr);
emit_const_reg(A_AND,S_L,$ff,hr);
end;
R_AH,R_BH,R_CH,R_DH:
begin
hr:=reg8toreg32(hr);
emit_const_reg(A_AND,S_L,$ff00,hr);
end;
end;
end;
{*****************************************************************************
Emit String Functions
*****************************************************************************}
procedure copyshortstring(const dref,sref : treference;len : byte;loadref:boolean);
begin
emitpushreferenceaddr(dref);
if loadref then
emit_push_mem(sref)
else
emitpushreferenceaddr(sref);
push_int(len);
emitcall('FPC_SHORTSTR_COPY');
maybe_loadesi;
end;
procedure copylongstring(const dref,sref : treference;len : longint;loadref:boolean);
begin
emitpushreferenceaddr(dref);
if loadref then
emit_push_mem(sref)
else
emitpushreferenceaddr(sref);
push_int(len);
emitcall('FPC_LONGSTR_COPY');
maybe_loadesi;
end;
procedure decrstringref(t : pdef;const ref : treference);
var
pushedregs : tpushed;
begin
pushusedregisters(pushedregs,$ff);
emitpushreferenceaddr(ref);
if is_ansistring(t) then
begin
emitcall('FPC_ANSISTR_DECR_REF');
end
else if is_widestring(t) then
begin
emitcall('FPC_WIDESTR_DECR_REF');
end
else internalerror(1859);
popusedregisters(pushedregs);
end;
procedure loadansistring(p : ptree);
{
copies an ansistring from p^.right to p^.left, we
assume, that both sides are ansistring, firstassignement have
to take care of that, an ansistring can't be a register variable
}
var
pushed : tpushed;
ungettemp : boolean;
begin
{ before pushing any parameter, we have to save all used }
{ registers, but before that we have to release the }
{ registers of that node to save uneccessary pushed }
{ so be careful, if you think you can optimize that code (FK) }
{ nevertheless, this has to be changed, because otherwise the }
{ register is released before it's contents are pushed -> }
{ problems with the optimizer (JM) }
del_reference(p^.left^.location.reference);
ungettemp:=false;
case p^.right^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
{$IfNDef regallocfix}
ungetregister32(p^.right^.location.register);
pushusedregisters(pushed,$ff);
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.right^.location.register)));
{$Else regallocfix}
pushusedregisters(pushed, $ff xor ($80 shr byte(p^.right^.location.register)));
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.right^.location.register)));
ungetregister32(p^.right^.location.register);
{$EndIf regallocfix}
end;
LOC_REFERENCE,LOC_MEM:
begin
{$IfNDef regallocfix}
del_reference(p^.right^.location.reference);
pushusedregisters(pushed,$ff);
emit_push_mem(p^.right^.location.reference);
{$Else regallocfix}
pushusedregisters(pushed,$ff
xor ($80 shr byte(p^.right^.location.reference.base))
xor ($80 shr byte(p^.right^.location.reference.index)));
emit_push_mem(p^.right^.location.reference);
del_reference(p^.right^.location.reference);
{$EndIf regallocfix}
ungettemp:=true;
end;
end;
emitpushreferenceaddr(p^.left^.location.reference);
del_reference(p^.left^.location.reference);
emitcall('FPC_ANSISTR_ASSIGN');
maybe_loadesi;
popusedregisters(pushed);
if ungettemp then
ungetiftemp(p^.right^.location.reference);
end;
{*****************************************************************************
Emit Push Functions
*****************************************************************************}
function maybe_push(needed : byte;p : ptree;isint64 : boolean) : boolean;
var
pushed : boolean;
{hregister : tregister; }
{$ifdef TEMPS_NOT_PUSH}
href : treference;
{$endif TEMPS_NOT_PUSH}
begin
if needed>usablereg32 then
begin
if (p^.location.loc=LOC_REGISTER) then
begin
if isint64 then
begin
{$ifdef TEMPS_NOT_PUSH}
gettempofsizereference(href,8);
p^.temp_offset:=href.offset;
href.offset:=href.offset+4;
exprasmlist^.concat(new(paicpu,op_reg(A_MOV,S_L,p^.location.registerhigh,href)));
href.offset:=href.offset-4;
{$else TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.registerhigh)));
{$endif TEMPS_NOT_PUSH}
ungetregister32(p^.location.registerhigh);
end
{$ifdef TEMPS_NOT_PUSH}
else
begin
gettempofsizereference(href,4);
p^.temp_offset:=href.offset;
end
{$endif TEMPS_NOT_PUSH}
;
pushed:=true;
{$ifdef TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,p^.location.register,href)));
{$else TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.register)));
{$endif TEMPS_NOT_PUSH}
ungetregister32(p^.location.register);
end
else if (p^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
((p^.location.reference.base<>R_NO) or
(p^.location.reference.index<>R_NO)
) then
begin
del_reference(p^.location.reference);
emit_ref_reg(A_LEA,S_L,newreference(p^.location.reference),
R_EDI);
{$ifdef TEMPS_NOT_PUSH}
gettempofsizereference(href,4);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,href)));
p^.temp_offset:=href.offset;
{$else TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI)));
{$endif TEMPS_NOT_PUSH}
pushed:=true;
end
else pushed:=false;
end
else pushed:=false;
maybe_push:=pushed;
end;
{$ifdef TEMPS_NOT_PUSH}
function maybe_savetotemp(needed : byte;p : ptree;isint64 : boolean) : boolean;
var
pushed : boolean;
href : treference;
begin
if needed>usablereg32 then
begin
if (p^.location.loc=LOC_REGISTER) then
begin
if isint64(p^.resulttype) then
begin
gettempofsizereference(href,8);
p^.temp_offset:=href.offset;
href.offset:=href.offset+4;
exprasmlist^.concat(new(paicpu,op_reg(A_MOV,S_L,p^.location.registerhigh,href)));
href.offset:=href.offset-4;
ungetregister32(p^.location.registerhigh);
end
else
begin
gettempofsizereference(href,4);
p^.temp_offset:=href.offset;
end;
pushed:=true;
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,p^.location.register,href)));
ungetregister32(p^.location.register);
end
else if (p^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
((p^.location.reference.base<>R_NO) or
(p^.location.reference.index<>R_NO)
) then
begin
del_reference(p^.location.reference);
emit_ref_reg(A_LEA,S_L,newreference(p^.location.reference),
R_EDI);
gettempofsizereference(href,4);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,href)));
p^.temp_offset:=href.offset;
pushed:=true;
end
else pushed:=false;
end
else pushed:=false;
maybe_push:=pushed;
end;
{$endif TEMPS_NOT_PUSH}
procedure push_int(l : longint);
begin
if (l = 0) and
not(aktoptprocessor in [Class386, ClassP6]) and
not(cs_littlesize in aktglobalswitches)
Then
begin
emit_reg_reg(A_XOR,S_L,R_EDI,R_EDI);
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI)));
end
else
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,l)));
end;
procedure emit_push_mem(const ref : treference);
begin
if ref.is_immediate then
push_int(ref.offset)
else
begin
if not(aktoptprocessor in [Class386, ClassP6]) and
not(cs_littlesize in aktglobalswitches)
then
begin
emit_ref_reg(A_MOV,S_L,newreference(ref),R_EDI);
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI)));
end
else exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,newreference(ref))));
end;
end;
procedure emitpushreferenceaddr(const ref : treference);
var
href : treference;
begin
{ this will fail for references to other segments !!! }
if ref.is_immediate then
{ is this right ? }
begin
{ push_int(ref.offset)}
gettempofsizereference(4,href);
emit_const_ref(A_MOV,S_L,ref.offset,newreference(href));
emitpushreferenceaddr(href);
del_reference(href);
end
else
begin
if ref.segment<>R_NO then
CGMessage(cg_e_cant_use_far_pointer_there);
if (ref.base=R_NO) and (ref.index=R_NO) then
exprasmlist^.concat(new(paicpu,op_sym_ofs(A_PUSH,S_L,ref.symbol,ref.offset)))
else if (ref.base=R_NO) and (ref.index<>R_NO) and
(ref.offset=0) and (ref.scalefactor=0) and (ref.symbol=nil) then
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,ref.index)))
else if (ref.base<>R_NO) and (ref.index=R_NO) and
(ref.offset=0) and (ref.symbol=nil) then
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,ref.base)))
else
begin
emit_ref_reg(A_LEA,S_L,newreference(ref),R_EDI);
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_EDI)));
end;
end;
end;
procedure pushsetelement(p : ptree);
{
copies p a set element on the stack
}
var
hr,hr16,hr32 : tregister;
begin
{ copy the element on the stack, slightly complicated }
if p^.treetype=ordconstn then
begin
if target_os.stackalignment=4 then
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,p^.value)))
else
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_W,p^.value)));
end
else
begin
case p^.location.loc of
LOC_REGISTER,
LOC_CREGISTER :
begin
hr:=p^.location.register;
case hr of
R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP :
begin
hr16:=reg32toreg16(hr);
hr32:=hr;
end;
R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP :
begin
hr16:=hr;
hr32:=reg16toreg32(hr);
end;
R_AL,R_BL,R_CL,R_DL :
begin
hr16:=reg8toreg16(hr);
hr32:=reg8toreg32(hr);
end;
end;
if target_os.stackalignment=4 then
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,hr32)))
else
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_W,hr16)));
ungetregister32(hr32);
end;
else
begin
if target_os.stackalignment=4 then
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,newreference(p^.location.reference))))
else
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_W,newreference(p^.location.reference))));
del_reference(p^.location.reference);
end;
end;
end;
end;
procedure restore(p : ptree;isint64 : boolean);
var
hregister : tregister;
{$ifdef TEMPS_NOT_PUSH}
href : treference;
{$endif TEMPS_NOT_PUSH}
begin
hregister:=getregister32;
{$ifdef TEMPS_NOT_PUSH}
reset_reference(href);
href.base:=procinfo^.frame_pointer;
href.offset:=p^.temp_offset;
emit_ref_reg(A_MOV,S_L,href,hregister);
{$else TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,hregister)));
{$endif TEMPS_NOT_PUSH}
if (p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
begin
p^.location.register:=hregister;
if isint64 then
begin
p^.location.registerhigh:=getregister32;
{$ifdef TEMPS_NOT_PUSH}
href.offset:=p^.temp_offset+4;
emit_ref_reg(A_MOV,S_L,p^.location.registerhigh);
{ set correctly for release ! }
href.offset:=p^.temp_offset;
{$else TEMPS_NOT_PUSH}
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,p^.location.registerhigh)));
{$endif TEMPS_NOT_PUSH}
end;
end
else
begin
reset_reference(p^.location.reference);
{ any reasons why this was moved into the index register ? }
{ normally usage of base register is much better (FK) }
p^.location.reference.base:=hregister;
{ Why is this done? We can never be sure about p^.left
because otherwise secondload fails !!!
set_location(p^.left^.location,p^.location);}
end;
{$ifdef TEMPS_NOT_PUSH}
ungetiftemp(href);
{$endif TEMPS_NOT_PUSH}
end;
{$ifdef TEMPS_NOT_PUSH}
procedure restorefromtemp(p : ptree;isint64 : boolean);
var
hregister : tregister;
href : treference;
begin
hregister:=getregister32;
reset_reference(href);
href.base:=procinfo^.frame_pointer;
href.offset:=p^.temp_offset;
emit_ref_reg(A_MOV,S_L,href,hregister);
if (p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
begin
p^.location.register:=hregister;
if isint64 then
begin
p^.location.registerhigh:=getregister32;
href.offset:=p^.temp_offset+4;
emit_ref_reg(A_MOV,S_L,p^.location.registerhigh);
{ set correctly for release ! }
href.offset:=p^.temp_offset;
end;
end
else
begin
reset_reference(p^.location.reference);
p^.location.reference.base:=hregister;
{ Why is this done? We can never be sure about p^.left
because otherwise secondload fails PM
set_location(p^.left^.location,p^.location);}
end;
ungetiftemp(href);
end;
{$endif TEMPS_NOT_PUSH}
procedure push_value_para(p:ptree;inlined:boolean;para_offset:longint;alignment : longint);
var
tempreference : treference;
r : preference;
opsize : topsize;
op : tasmop;
hreg : tregister;
size : longint;
hlabel : pasmlabel;
begin
case p^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
case p^.location.register of
R_EAX,R_EBX,R_ECX,R_EDX,R_ESI,
R_EDI,R_ESP,R_EBP :
begin
if p^.resulttype^.size=8 then
begin
inc(pushedparasize,8);
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,
p^.location.registerlow,r)));
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize+4);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,
p^.location.registerhigh,r)));
end
else
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.registerhigh)));
ungetregister32(p^.location.registerhigh);
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.registerlow)));
ungetregister32(p^.location.registerlow);
end
else
begin
inc(pushedparasize,4);
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,
p^.location.register,r)));
end
else
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.location.register)));
ungetregister32(p^.location.register);
end;
end;
R_AX,R_BX,R_CX,R_DX,R_SI,R_DI:
begin
if alignment=4 then
begin
opsize:=S_L;
hreg:=reg16toreg32(p^.location.register);
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=p^.location.register;
inc(pushedparasize,2);
end;
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,opsize,hreg)));
ungetregister32(reg16toreg32(p^.location.register));
end;
R_AL,R_BL,R_CL,R_DL:
begin
if alignment=4 then
begin
opsize:=S_L;
hreg:=reg8toreg32(p^.location.register);
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=reg8toreg16(p^.location.register);
inc(pushedparasize,2);
end;
{ we must push always 16 bit }
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,opsize,hreg)));
ungetregister32(reg8toreg32(p^.location.register));
end;
else internalerror(1899);
end;
end;
LOC_FPU:
begin
size:=align(pfloatdef(p^.resulttype)^.size,alignment);
inc(pushedparasize,size);
if not inlined then
emit_const_reg(A_SUB,S_L,size,R_ESP);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and
(exprasmlist^.first=exprasmlist^.last) then
exprasmlist^.concat(new(pai_force_line,init));
{$endif GDB}
r:=new_reference(R_ESP,0);
floatstoreops(pfloatdef(p^.resulttype)^.typ,op,opsize);
{ this is the easiest case for inlined !! }
if inlined then
begin
r^.base:=procinfo^.framepointer;
r^.offset:=para_offset-pushedparasize;
end;
exprasmlist^.concat(new(paicpu,op_ref(op,opsize,r)));
dec(fpuvaroffset);
end;
LOC_CFPUREGISTER:
begin
exprasmlist^.concat(new(paicpu,op_reg(A_FLD,S_NO,
correct_fpuregister(p^.location.register,fpuvaroffset))));
size:=align(pfloatdef(p^.resulttype)^.size,alignment);
inc(pushedparasize,size);
if not inlined then
emit_const_reg(A_SUB,S_L,size,R_ESP);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and
(exprasmlist^.first=exprasmlist^.last) then
exprasmlist^.concat(new(pai_force_line,init));
{$endif GDB}
r:=new_reference(R_ESP,0);
floatstoreops(pfloatdef(p^.resulttype)^.typ,op,opsize);
{ this is the easiest case for inlined !! }
if inlined then
begin
r^.base:=procinfo^.framepointer;
r^.offset:=para_offset-pushedparasize;
end;
exprasmlist^.concat(new(paicpu,op_ref(op,opsize,r)));
end;
LOC_REFERENCE,LOC_MEM:
begin
tempreference:=p^.location.reference;
del_reference(p^.location.reference);
case p^.resulttype^.deftype of
enumdef,
orddef :
begin
case p^.resulttype^.size of
8 : begin
inc(pushedparasize,8);
if inlined then
begin
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
inc(tempreference.offset,4);
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize+4);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
begin
inc(tempreference.offset,4);
emit_push_mem(tempreference);
dec(tempreference.offset,4);
emit_push_mem(tempreference);
end;
end;
4 : begin
inc(pushedparasize,4);
if inlined then
begin
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
end;
1,2 : begin
if alignment=4 then
begin
opsize:=S_L;
hreg:=R_EDI;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=R_DI;
inc(pushedparasize,2);
end;
if inlined then
begin
emit_ref_reg(A_MOV,opsize,
newreference(tempreference),hreg);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,opsize,
newreference(tempreference))));
end;
else
internalerror(234231);
end;
end;
floatdef :
begin
case pfloatdef(p^.resulttype)^.typ of
f32bit,
s32real :
begin
inc(pushedparasize,4);
if inlined then
begin
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
end;
s64real,
s64comp :
begin
inc(pushedparasize,4);
inc(tempreference.offset,4);
if inlined then
begin
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
inc(pushedparasize,4);
dec(tempreference.offset,4);
if inlined then
begin
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
end;
s80real :
begin
inc(pushedparasize,4);
if alignment=4 then
inc(tempreference.offset,8)
else
inc(tempreference.offset,6);
if inlined then
begin
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
dec(tempreference.offset,4);
inc(pushedparasize,4);
if inlined then
begin
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
if alignment=4 then
begin
opsize:=S_L;
hreg:=R_EDI;
inc(pushedparasize,4);
dec(tempreference.offset,4);
end
else
begin
opsize:=S_W;
hreg:=R_DI;
inc(pushedparasize,2);
dec(tempreference.offset,2);
end;
if inlined then
begin
emit_ref_reg(A_MOV,opsize,
newreference(tempreference),hreg);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,opsize,
newreference(tempreference))));
end;
end;
end;
pointerdef,
procvardef,
classrefdef:
begin
inc(pushedparasize,4);
if inlined then
begin
emit_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI);
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
end;
arraydef,
recorddef,
stringdef,
setdef,
objectdef :
begin
{ even some structured types are 32 bit }
if is_widestring(p^.resulttype) or
is_ansistring(p^.resulttype) or
is_smallset(p^.resulttype) or
((p^.resulttype^.deftype in [recorddef,arraydef]) and (p^.resulttype^.size<=4)
and ((p^.resulttype^.deftype<>arraydef) or not
(parraydef(p^.resulttype)^.IsConstructor or
parraydef(p^.resulttype)^.isArrayOfConst or
is_open_array(p^.resulttype)))
) or
((p^.resulttype^.deftype=objectdef) and
pobjectdef(p^.resulttype)^.is_class) then
begin
inc(pushedparasize,4);
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
concatcopy(tempreference,r^,4,false,false);
end
else
emit_push_mem(tempreference);
end
{ call by value open array ? }
else
internalerror(8954);
end;
else
CGMessage(cg_e_illegal_expression);
end;
end;
LOC_JUMP:
begin
getlabel(hlabel);
if alignment=4 then
begin
opsize:=S_L;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
inc(pushedparasize,2);
end;
emitlab(truelabel);
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
emit_const_ref(A_MOV,opsize,1,r);
end
else
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,opsize,1)));
emitjmp(C_None,hlabel);
emitlab(falselabel);
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
emit_const_ref(A_MOV,opsize,0,r);
end
else
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,opsize,0)));
emitlab(hlabel);
end;
LOC_FLAGS:
begin
if not(R_EAX in unused) then
emit_reg_reg(A_MOV,S_L,R_EAX,R_EDI);
emit_flag2reg(p^.location.resflags,R_AL);
emit_reg_reg(A_MOVZX,S_BW,R_AL,R_AX);
if alignment=4 then
begin
opsize:=S_L;
hreg:=R_EAX;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=R_AX;
inc(pushedparasize,2);
end;
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,opsize,hreg)));
if not(R_EAX in unused) then
emit_reg_reg(A_MOV,S_L,R_EDI,R_EAX);
end;
{$ifdef SUPPORT_MMX}
LOC_MMXREGISTER,
LOC_CMMXREGISTER:
begin
inc(pushedparasize,8); { was missing !!! (PM) }
emit_const_reg(
A_SUB,S_L,8,R_ESP);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and
(exprasmlist^.first=exprasmlist^.last) then
exprasmlist^.concat(new(pai_force_line,init));
{$endif GDB}
if inlined then
begin
r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOVQ,S_NO,
p^.location.register,r)));
end
else
begin
r:=new_reference(R_ESP,0);
exprasmlist^.concat(new(paicpu,op_reg_ref(
A_MOVQ,S_NO,p^.location.register,r)));
end;
end;
{$endif SUPPORT_MMX}
end;
end;
{*****************************************************************************
Emit Float Functions
*****************************************************************************}
procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize);
begin
case t of
s32real : begin
op:=A_FLD;
s:=S_FS;
end;
s64real : begin
op:=A_FLD;
{ ???? }
s:=S_FL;
end;
s80real : begin
op:=A_FLD;
s:=S_FX;
end;
s64comp : begin
op:=A_FILD;
s:=S_IQ;
end;
else internalerror(17);
end;
end;
procedure floatload(t : tfloattype;const ref : treference);
var
op : tasmop;
s : topsize;
begin
floatloadops(t,op,s);
exprasmlist^.concat(new(paicpu,op_ref(op,s,
newreference(ref))));
inc(fpuvaroffset);
end;
procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize);
begin
case t of
s32real : begin
op:=A_FSTP;
s:=S_FS;
end;
s64real : begin
op:=A_FSTP;
s:=S_FL;
end;
s80real : begin
op:=A_FSTP;
s:=S_FX;
end;
s64comp : begin
op:=A_FISTP;
s:=S_IQ;
end;
else
internalerror(17);
end;
end;
procedure floatstore(t : tfloattype;const ref : treference);
var
op : tasmop;
s : topsize;
begin
floatstoreops(t,op,s);
exprasmlist^.concat(new(paicpu,op_ref(op,s,
newreference(ref))));
dec(fpuvaroffset);
end;
{*****************************************************************************
Emit Functions
*****************************************************************************}
procedure maketojumpbool(p : ptree);
{
produces jumps to true respectively false labels using boolean expressions
}
var
opsize : topsize;
storepos : tfileposinfo;
begin
if p^.error then
exit;
storepos:=aktfilepos;
aktfilepos:=p^.fileinfo;
if is_boolean(p^.resulttype) then
begin
if is_constboolnode(p) then
begin
if p^.value<>0 then
emitjmp(C_None,truelabel)
else
emitjmp(C_None,falselabel);
end
else
begin
opsize:=def_opsize(p^.resulttype);
case p^.location.loc of
LOC_CREGISTER,LOC_REGISTER : begin
emit_reg_reg(A_OR,opsize,p^.location.register,
p^.location.register);
ungetregister(p^.location.register);
emitjmp(C_NZ,truelabel);
emitjmp(C_None,falselabel);
end;
LOC_MEM,LOC_REFERENCE : begin
emit_const_ref(
A_CMP,opsize,0,newreference(p^.location.reference));
del_reference(p^.location.reference);
emitjmp(C_NZ,truelabel);
emitjmp(C_None,falselabel);
end;
LOC_FLAGS : begin
emitjmp(flag_2_cond[p^.location.resflags],truelabel);
emitjmp(C_None,falselabel);
end;
end;
end;
end
else
CGMessage(type_e_mismatch);
aktfilepos:=storepos;
end;
{ produces if necessary overflowcode }
procedure emitoverflowcheck(p:ptree);
var
hl : pasmlabel;
begin
if not(cs_check_overflow in aktlocalswitches) then
exit;
getlabel(hl);
if not ((p^.resulttype^.deftype=pointerdef) or
((p^.resulttype^.deftype=orddef) and
(porddef(p^.resulttype)^.typ in [u64bit,u16bit,u32bit,u8bit,uchar,
bool8bit,bool16bit,bool32bit]))) then
emitjmp(C_NO,hl)
else
emitjmp(C_NB,hl);
emitcall('FPC_OVERFLOW');
emitlab(hl);
end;
{ produces range check code, while one of the operands is a 64 bit
integer }
procedure emitrangecheck64(p : ptree;todef : pdef);
begin
internalerror(28699);
end;
{ produces if necessary rangecheckcode }
procedure emitrangecheck(p:ptree;todef:pdef);
{
generate range checking code for the value at location t. The
type used is the checked against todefs ranges. fromdef (p.resulttype)
is the original type used at that location, when both defs are
equal the check is also insert (needed for succ,pref,inc,dec)
}
var
neglabel,
poslabel : pasmlabel;
href : treference;
rstr : string;
hreg : tregister;
opsize : topsize;
op : tasmop;
fromdef : pdef;
lto,hto,
lfrom,hfrom : longint;
doublebound,
is_reg,
popecx : boolean;
begin
{ range checking on and range checkable value? }
if not(cs_check_range in aktlocalswitches) or
not(todef^.deftype in [orddef,enumdef,arraydef]) then
exit;
{ only check when assigning to scalar, subranges are different,
when todef=fromdef then the check is always generated }
fromdef:=p^.resulttype;
if is_64bitint(fromdef) or is_64bitint(todef) then
begin
emitrangecheck64(p,todef);
exit;
end;
{we also need lto and hto when checking if we need to use doublebound!
(JM)}
getrange(todef,lto,hto);
if todef<>fromdef then
begin
getrange(p^.resulttype,lfrom,hfrom);
{ first check for not being u32bit, then if the to is bigger than
from }
if (lto<hto) and (lfrom<hfrom) and
(lto<=lfrom) and (hto>=hfrom) then
exit;
end;
{ generate the rangecheck code for the def where we are going to
store the result }
doublebound:=false;
case todef^.deftype of
orddef :
begin
porddef(todef)^.genrangecheck;
rstr:=porddef(todef)^.getrangecheckstring;
doublebound:=(porddef(todef)^.typ=u32bit) and (lto>hto);
end;
enumdef :
begin
penumdef(todef)^.genrangecheck;
rstr:=penumdef(todef)^.getrangecheckstring;
end;
arraydef :
begin
parraydef(todef)^.genrangecheck;
rstr:=parraydef(todef)^.getrangecheckstring;
end;
end;
{ get op and opsize }
opsize:=def2def_opsize(fromdef,u32bitdef);
if opsize in [S_B,S_W,S_L] then
op:=A_MOV
else
if is_signed(fromdef) then
op:=A_MOVSX
else
op:=A_MOVZX;
is_reg:=(p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]);
if is_reg then
hreg:=p^.location.register;
if not target_os.use_bound_instruction then
begin
{ FPC_BOUNDCHECK needs to be called with
%ecx - value
%edi - pointer to the ranges }
popecx:=false;
if not(is_reg) or
(p^.location.register<>R_ECX) then
begin
if not(R_ECX in unused) then
begin
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_ECX)));
popecx:=true;
end;
if is_reg then
emit_reg_reg(op,opsize,p^.location.register,R_ECX)
else
emit_ref_reg(op,opsize,newreference(p^.location.reference),R_ECX);
end;
if doublebound then
begin
getlabel(neglabel);
getlabel(poslabel);
emit_reg_reg(A_OR,S_L,R_ECX,R_ECX);
emitjmp(C_L,neglabel);
end;
{ insert bound instruction only }
exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,newasmsymbol(rstr),0,R_EDI)));
emitcall('FPC_BOUNDCHECK');
{ u32bit needs 2 checks }
if doublebound then
begin
emitjmp(C_None,poslabel);
emitlab(neglabel);
exprasmlist^.concat(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,newasmsymbol(rstr),8,R_EDI)));
emitcall('FPC_BOUNDCHECK');
emitlab(poslabel);
end;
if popecx then
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ECX)));
end
else
begin
reset_reference(href);
href.symbol:=newasmsymbol(rstr);
{ load the value in a register }
if is_reg then
begin
{ be sure that hreg is a 32 bit reg, if not load it in %edi }
if p^.location.register in [R_EAX..R_EDI] then
hreg:=p^.location.register
else
begin
emit_reg_reg(op,opsize,p^.location.register,R_EDI);
hreg:=R_EDI;
end;
end
else
begin
emit_ref_reg(op,opsize,newreference(p^.location.reference),R_EDI);
hreg:=R_EDI;
end;
if doublebound then
begin
getlabel(neglabel);
getlabel(poslabel);
emit_reg_reg(A_OR,S_L,hreg,hreg);
emitjmp(C_L,neglabel);
end;
{ insert bound instruction only }
exprasmlist^.concat(new(paicpu,op_reg_ref(A_BOUND,S_L,hreg,newreference(href))));
{ u32bit needs 2 checks }
if doublebound then
begin
href.offset:=8;
emitjmp(C_None,poslabel);
emitlab(neglabel);
exprasmlist^.concat(new(paicpu,op_reg_ref(A_BOUND,S_L,hreg,newreference(href))));
emitlab(poslabel);
end;
end;
end;
procedure concatcopy(source,dest : treference;size : longint;delsource,loadref : boolean);
const
isizes : array[0..3] of topsize=(S_L,S_B,S_W,S_B);
ishr : array[0..3] of byte=(2,0,1,0);
var
ecxpushed : boolean;
helpsize : longint;
i : byte;
reg8,reg32 : tregister;
swap : boolean;
procedure maybepushecx;
begin
if not(R_ECX in unused) then
begin
exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,R_ECX)));
ecxpushed:=true;
end;
end;
begin
{$IfNDef regallocfix}
If delsource then
del_reference(source);
{$EndIf regallocfix}
if (not loadref) and
((size<=8) or
(not(cs_littlesize in aktglobalswitches ) and (size<=12))) then
begin
helpsize:=size shr 2;
for i:=1 to helpsize do
begin
emit_ref_reg(A_MOV,S_L,newreference(source),R_EDI);
{$ifdef regallocfix}
If (size = 4) and delsource then
del_reference(source);
{$endif regallocfix}
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_L,R_EDI,newreference(dest))));
inc(source.offset,4);
inc(dest.offset,4);
dec(size,4);
end;
if size>1 then
begin
emit_ref_reg(A_MOV,S_W,newreference(source),R_DI);
{$ifdef regallocfix}
If (size = 2) and delsource then
del_reference(source);
{$endif regallocfix}
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_W,R_DI,newreference(dest))));
inc(source.offset,2);
inc(dest.offset,2);
dec(size,2);
end;
if size>0 then
begin
{ and now look for an 8 bit register }
swap:=false;
if R_EAX in unused then reg8:=R_AL
else if R_EBX in unused then reg8:=R_BL
else if R_ECX in unused then reg8:=R_CL
else if R_EDX in unused then reg8:=R_DL
else
begin
swap:=true;
{ we need only to check 3 registers, because }
{ one is always not index or base }
if (dest.base<>R_EAX) and (dest.index<>R_EAX) then
begin
reg8:=R_AL;
reg32:=R_EAX;
end
else if (dest.base<>R_EBX) and (dest.index<>R_EBX) then
begin
reg8:=R_BL;
reg32:=R_EBX;
end
else if (dest.base<>R_ECX) and (dest.index<>R_ECX) then
begin
reg8:=R_CL;
reg32:=R_ECX;
end;
end;
if swap then
{ was earlier XCHG, of course nonsense }
emit_reg_reg(A_MOV,S_L,reg32,R_EDI);
emit_ref_reg(A_MOV,S_B,newreference(source),reg8);
{$ifdef regallocfix}
If delsource then
del_reference(source);
{$endif regallocfix}
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,S_B,reg8,newreference(dest))));
if swap then
emit_reg_reg(A_MOV,S_L,R_EDI,reg32);
end;
end
else
begin
emit_ref_reg(A_LEA,S_L,newreference(dest),R_EDI);
{$ifdef regallocfix}
{is this ok?? (JM)}
del_reference(dest);
{$endif regallocfix}
if loadref then
emit_ref_reg(A_MOV,S_L,newreference(source),R_ESI)
else
begin
emit_ref_reg(A_LEA,S_L,newreference(source),R_ESI);
{$ifdef regallocfix}
if delsource then
del_reference(source);
{$endif regallocfix}
end;
exprasmlist^.concat(new(paicpu,op_none(A_CLD,S_NO)));
ecxpushed:=false;
if cs_littlesize in aktglobalswitches then
begin
maybepushecx;
emit_const_reg(A_MOV,S_L,size,R_ECX);
exprasmlist^.concat(new(paicpu,op_none(A_REP,S_NO)));
exprasmlist^.concat(new(paicpu,op_none(A_MOVSB,S_NO)));
end
else
begin
helpsize:=size shr 2;
size:=size and 3;
if helpsize>1 then
begin
maybepushecx;
emit_const_reg(A_MOV,S_L,helpsize,R_ECX);
exprasmlist^.concat(new(paicpu,op_none(A_REP,S_NO)));
end;
if helpsize>0 then
exprasmlist^.concat(new(paicpu,op_none(A_MOVSD,S_NO)));
if size>1 then
begin
dec(size,2);
exprasmlist^.concat(new(paicpu,op_none(A_MOVSW,S_NO)));
end;
if size=1 then
exprasmlist^.concat(new(paicpu,op_none(A_MOVSB,S_NO)));
end;
if ecxpushed then
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ECX)));
{ loading SELF-reference again }
maybe_loadesi;
end;
if delsource then
ungetiftemp(source);
end;
procedure emitloadord2reg(const location:Tlocation;orddef:Porddef;
destreg:Tregister;delloc:boolean);
{A lot smaller and less bug sensitive than the original unfolded loads.}
var tai:Paicpu;
r:Preference;
begin
case location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
case orddef^.typ of
u8bit:
tai:=new(paicpu,op_reg_reg(A_MOVZX,S_BL,location.register,destreg));
s8bit:
tai:=new(paicpu,op_reg_reg(A_MOVSX,S_BL,location.register,destreg));
u16bit:
tai:=new(paicpu,op_reg_reg(A_MOVZX,S_WL,location.register,destreg));
s16bit:
tai:=new(paicpu,op_reg_reg(A_MOVSX,S_WL,location.register,destreg));
u32bit:
tai:=new(paicpu,op_reg_reg(A_MOV,S_L,location.register,destreg));
s32bit:
tai:=new(paicpu,op_reg_reg(A_MOV,S_L,location.register,destreg));
end;
if delloc then
ungetregister(location.register);
end;
LOC_MEM,
LOC_REFERENCE:
begin
if location.reference.is_immediate then
tai:=new(paicpu,op_const_reg(A_MOV,S_L,location.reference.offset,destreg))
else
begin
r:=newreference(location.reference);
case orddef^.typ of
u8bit:
tai:=new(paicpu,op_ref_reg(A_MOVZX,S_BL,r,destreg));
s8bit:
tai:=new(paicpu,op_ref_reg(A_MOVSX,S_BL,r,destreg));
u16bit:
tai:=new(paicpu,op_ref_reg(A_MOVZX,S_WL,r,destreg));
s16bit:
tai:=new(paicpu,op_ref_reg(A_MOVSX,S_WL,r,destreg));
u32bit:
tai:=new(paicpu,op_ref_reg(A_MOV,S_L,r,destreg));
s32bit:
tai:=new(paicpu,op_ref_reg(A_MOV,S_L,r,destreg));
end;
end;
if delloc then
del_reference(location.reference);
end
else
internalerror(6);
end;
exprasmlist^.concat(tai);
end;
{ if necessary ESI is reloaded after a call}
procedure maybe_loadesi;
var
hp : preference;
p : pprocinfo;
i : longint;
begin
if assigned(procinfo^._class) then
begin
if lexlevel>normal_function_level then
begin
new(hp);
reset_reference(hp^);
hp^.offset:=procinfo^.framepointer_offset;
hp^.base:=procinfo^.framepointer;
emit_ref_reg(A_MOV,S_L,hp,R_ESI);
p:=procinfo^.parent;
for i:=3 to lexlevel-1 do
begin
new(hp);
reset_reference(hp^);
hp^.offset:=p^.framepointer_offset;
hp^.base:=R_ESI;
emit_ref_reg(A_MOV,S_L,hp,R_ESI);
p:=p^.parent;
end;
new(hp);
reset_reference(hp^);
hp^.offset:=p^.ESI_offset;
hp^.base:=R_ESI;
emit_ref_reg(A_MOV,S_L,hp,R_ESI);
end
else
begin
new(hp);
reset_reference(hp^);
hp^.offset:=procinfo^.ESI_offset;
hp^.base:=procinfo^.framepointer;
emit_ref_reg(A_MOV,S_L,hp,R_ESI);
end;
end;
end;
procedure firstcomplex(p : ptree);
var
hp : ptree;
begin
{ always calculate boolean AND and OR from left to right }
if (p^.treetype in [orn,andn]) and
(p^.left^.resulttype^.deftype=orddef) and
(porddef(p^.left^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit]) then
p^.swaped:=false
else
if (p^.left^.registers32<p^.right^.registers32) and
{ the following check is appropriate, because all }
{ 4 registers are rarely used and it is thereby }
{ achieved that the extra code is being dropped }
{ by exchanging not commutative operators }
(p^.right^.registers32<=4) then
begin
hp:=p^.left;
p^.left:=p^.right;
p^.right:=hp;
p^.swaped:=true;
end
else
p^.swaped:=false;
end;
{*****************************************************************************
Entry/Exit Code Functions
*****************************************************************************}
procedure genprofilecode;
var
pl : pasmlabel;
begin
if (po_assembler in aktprocsym^.definition^.procoptions) then
exit;
case target_info.target of
target_i386_linux:
begin
getlabel(pl);
emitcall('mcount');
exprasmlist^.insert(new(paicpu,op_sym_ofs_reg(A_MOV,S_L,pl,0,R_EDX)));
exprasmlist^.insert(new(pai_section,init(sec_code)));
exprasmlist^.insert(new(pai_const,init_32bit(0)));
exprasmlist^.insert(new(pai_label,init(pl)));
exprasmlist^.insert(new(pai_align,init(4)));
exprasmlist^.insert(new(pai_section,init(sec_data)));
end;
target_i386_go32v2:
begin
emitinsertcall('MCOUNT');
end;
end;
end;
procedure generate_interrupt_stackframe_entry;
begin
{ save the registers of an interrupt procedure }
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EAX)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EBX)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_ECX)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EDX)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_ESI)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EDI)));
{ .... also the segment registers }
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_W,R_DS)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_W,R_ES)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_W,R_FS)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_W,R_GS)));
end;
procedure generate_interrupt_stackframe_exit;
begin
{ restore the registers of an interrupt procedure }
{ this was all with entrycode instead of exitcode !!}
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_L,R_EAX)));
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_L,R_EBX)));
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_L,R_ECX)));
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_L,R_EDX)));
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_L,R_ESI)));
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_L,R_EDI)));
{ .... also the segment registers }
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_W,R_DS)));
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_W,R_ES)));
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_W,R_FS)));
procinfo^.aktexitcode^.concat(new(paicpu,op_reg(A_POP,S_W,R_GS)));
{ this restores the flags }
procinfo^.aktexitcode^.concat(new(paicpu,op_none(A_IRET,S_NO)));
end;
{ generates the code for threadvar initialisation }
procedure initialize_threadvar(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
var
hr : treference;
begin
if (psym(p)^.typ=varsym) and
(vo_is_thread_var in pvarsym(p)^.varoptions) then
begin
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,pvarsym(p)^.getsize)));
reset_reference(hr);
hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
emitpushreferenceaddr(hr);
emitcall('FPC_INIT_THREADVAR');
end;
end;
{ initilizes data of type t }
{ if is_already_ref is true then the routines assumes }
{ that r points to the data to initialize }
procedure initialize(t : pdef;const ref : treference;is_already_ref : boolean);
var
hr : treference;
begin
if is_ansistring(t) or
is_widestring(t) then
begin
emit_const_ref(A_MOV,S_L,0,
newreference(ref));
end
else
begin
reset_reference(hr);
hr.symbol:=t^.get_inittable_label;
emitpushreferenceaddr(hr);
if is_already_ref then
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,
newreference(ref))))
else
emitpushreferenceaddr(ref);
emitcall('FPC_INITIALIZE');
end;
end;
{ finalizes data of type t }
{ if is_already_ref is true then the routines assumes }
{ that r points to the data to finalizes }
procedure finalize(t : pdef;const ref : treference;is_already_ref : boolean);
var
r : treference;
begin
if is_ansistring(t) or
is_widestring(t) then
begin
decrstringref(t,ref);
end
else
begin
reset_reference(r);
r.symbol:=t^.get_inittable_label;
emitpushreferenceaddr(r);
if is_already_ref then
exprasmlist^.concat(new(paicpu,op_ref(A_PUSH,S_L,
newreference(ref))))
else
emitpushreferenceaddr(ref);
emitcall('FPC_FINALIZE');
end;
end;
{ generates the code for initialisation of local data }
procedure initialize_data(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
var
hr : treference;
begin
if (psym(p)^.typ=varsym) and
assigned(pvarsym(p)^.definition) and
not((pvarsym(p)^.definition^.deftype=objectdef) and
pobjectdef(pvarsym(p)^.definition)^.is_class) and
pvarsym(p)^.definition^.needs_inittable then
begin
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
reset_reference(hr);
if psym(p)^.owner^.symtabletype=localsymtable then
begin
hr.base:=procinfo^.framepointer;
hr.offset:=-pvarsym(p)^.address;
end
else
begin
hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
end;
initialize(pvarsym(p)^.definition,hr,false);
end;
end;
{ generates the code for incrementing the reference count of parameters }
procedure incr_data(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
var
hr : treference;
begin
if (psym(p)^.typ=varsym) and
not((pvarsym(p)^.definition^.deftype=objectdef) and
pobjectdef(pvarsym(p)^.definition)^.is_class) and
pvarsym(p)^.definition^.needs_inittable and
((pvarsym(p)^.varspez=vs_value) {or
(pvarsym(p)^.varspez=vs_const) and
not(dont_copy_const_param(pvarsym(p)^.definition))}) then
begin
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
reset_reference(hr);
hr.symbol:=pvarsym(p)^.definition^.get_inittable_label;
emitpushreferenceaddr(hr);
reset_reference(hr);
hr.base:=procinfo^.framepointer;
hr.offset:=pvarsym(p)^.address+procinfo^.call_offset;
emitpushreferenceaddr(hr);
reset_reference(hr);
emitcall('FPC_ADDREF');
end;
end;
{ generates the code for finalisation of local data }
procedure finalize_data(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
var
hr : treference;
begin
if (psym(p)^.typ=varsym) and
assigned(pvarsym(p)^.definition) and
not((pvarsym(p)^.definition^.deftype=objectdef) and
pobjectdef(pvarsym(p)^.definition)^.is_class) and
pvarsym(p)^.definition^.needs_inittable then
begin
{ not all kind of parameters need to be finalized }
if (psym(p)^.owner^.symtabletype=parasymtable) and
((pvarsym(p)^.varspez=vs_var) or
(pvarsym(p)^.varspez=vs_const) { and
(dont_copy_const_param(pvarsym(p)^.definition)) } ) then
exit;
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
reset_reference(hr);
case psym(p)^.owner^.symtabletype of
localsymtable:
begin
hr.base:=procinfo^.framepointer;
hr.offset:=-pvarsym(p)^.address;
end;
parasymtable:
begin
hr.base:=procinfo^.framepointer;
hr.offset:=pvarsym(p)^.address+procinfo^.call_offset;
end;
else
hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
end;
finalize(pvarsym(p)^.definition,hr,false);
end;
end;
{ generates the code to make local copies of the value parameters }
procedure copyvalueparas(p : pnamedindexobject);{$ifndef fpc}far;{$endif}
var
href1,href2 : treference;
r : preference;
len : longint;
opsize : topsize;
again,ok : pasmlabel;
begin
if (psym(p)^.typ=varsym) and
(pvarsym(p)^.varspez=vs_value) and
(push_addr_param(pvarsym(p)^.definition)) then
begin
if is_open_array(pvarsym(p)^.definition) or
is_array_of_const(pvarsym(p)^.definition) then
begin
{ get stack space }
new(r);
reset_reference(r^);
r^.base:=procinfo^.framepointer;
r^.offset:=pvarsym(p)^.address+4+procinfo^.call_offset;
exprasmlist^.concat(new(paicpu,
op_ref_reg(A_MOV,S_L,r,R_EDI)));
exprasmlist^.concat(new(paicpu,
op_reg(A_INC,S_L,R_EDI)));
exprasmlist^.concat(new(paicpu,
op_const_reg(A_IMUL,S_L,
parraydef(pvarsym(p)^.definition)^.definition^.size,R_EDI)));
{ windows guards only a few pages for stack growing, }
{ so we have to access every page first }
if target_os.id=os_i386_win32 then
begin
getlabel(again);
getlabel(ok);
emitlab(again);
exprasmlist^.concat(new(paicpu,
op_const_reg(A_CMP,S_L,winstackpagesize,R_EDI)));
emitjmp(C_C,ok);
exprasmlist^.concat(new(paicpu,
op_const_reg(A_SUB,S_L,winstackpagesize-4,R_ESP)));
exprasmlist^.concat(new(paicpu,
op_reg(A_PUSH,S_L,R_EAX)));
exprasmlist^.concat(new(paicpu,
op_const_reg(A_SUB,S_L,winstackpagesize,R_EDI)));
emitjmp(C_None,again);
emitlab(ok);
exprasmlist^.concat(new(paicpu,
op_reg_reg(A_SUB,S_L,R_EDI,R_ESP)));
{ now reload EDI }
new(r);
reset_reference(r^);
r^.base:=procinfo^.framepointer;
r^.offset:=pvarsym(p)^.address+4+procinfo^.call_offset;
exprasmlist^.concat(new(paicpu,
op_ref_reg(A_MOV,S_L,r,R_EDI)));
exprasmlist^.concat(new(paicpu,
op_reg(A_INC,S_L,R_EDI)));
exprasmlist^.concat(new(paicpu,
op_const_reg(A_IMUL,S_L,
parraydef(pvarsym(p)^.definition)^.definition^.size,R_EDI)));
end
else
begin
exprasmlist^.concat(new(paicpu,
op_reg_reg(A_SUB,S_L,R_EDI,R_ESP)));
{ load destination }
exprasmlist^.concat(new(paicpu,
op_reg_reg(A_MOV,S_L,R_ESP,R_EDI)));
end;
{ don't destroy the registers! }
exprasmlist^.concat(new(paicpu,
op_reg(A_PUSH,S_L,R_ECX)));
exprasmlist^.concat(new(paicpu,
op_reg(A_PUSH,S_L,R_ESI)));
{ load count }
new(r);
reset_reference(r^);
r^.base:=procinfo^.framepointer;
r^.offset:=pvarsym(p)^.address+4+procinfo^.call_offset;
exprasmlist^.concat(new(paicpu,
op_ref_reg(A_MOV,S_L,r,R_ECX)));
{ load source }
new(r);
reset_reference(r^);
r^.base:=procinfo^.framepointer;
r^.offset:=pvarsym(p)^.address+procinfo^.call_offset;
exprasmlist^.concat(new(paicpu,
op_ref_reg(A_MOV,S_L,r,R_ESI)));
{ scheduled .... }
exprasmlist^.concat(new(paicpu,
op_reg(A_INC,S_L,R_ECX)));
{ calculate size }
len:=parraydef(pvarsym(p)^.definition)^.definition^.size;
opsize:=S_B;
if (len and 3)=0 then
begin
opsize:=S_L;
len:=len shr 2;
end
else
if (len and 1)=0 then
begin
opsize:=S_W;
len:=len shr 1;
end;
exprasmlist^.concat(new(paicpu,
op_const_reg(A_IMUL,S_L,len,R_ECX)));
exprasmlist^.concat(new(paicpu,
op_none(A_REP,S_NO)));
case opsize of
S_B : exprasmlist^.concat(new(paicpu,op_none(A_MOVSB,S_NO)));
S_W : exprasmlist^.concat(new(paicpu,op_none(A_MOVSW,S_NO)));
S_L : exprasmlist^.concat(new(paicpu,op_none(A_MOVSD,S_NO)));
end;
exprasmlist^.concat(new(paicpu,
op_reg(A_POP,S_L,R_ESI)));
exprasmlist^.concat(new(paicpu,
op_reg(A_POP,S_L,R_ECX)));
{ patch the new address }
new(r);
reset_reference(r^);
r^.base:=procinfo^.framepointer;
r^.offset:=pvarsym(p)^.address+procinfo^.call_offset;
exprasmlist^.concat(new(paicpu,
op_reg_ref(A_MOV,S_L,R_ESP,r)));
end
else
if is_shortstring(pvarsym(p)^.definition) then
begin
reset_reference(href1);
href1.base:=procinfo^.framepointer;
href1.offset:=pvarsym(p)^.address+procinfo^.call_offset;
reset_reference(href2);
href2.base:=procinfo^.framepointer;
href2.offset:=-pvarsym(p)^.localvarsym^.address;
copyshortstring(href2,href1,pstringdef(pvarsym(p)^.definition)^.len,true);
end
else
begin
reset_reference(href1);
href1.base:=procinfo^.framepointer;
href1.offset:=pvarsym(p)^.address+procinfo^.call_offset;
reset_reference(href2);
href2.base:=procinfo^.framepointer;
href2.offset:=-pvarsym(p)^.localvarsym^.address;
concatcopy(href1,href2,pvarsym(p)^.definition^.size,true,true);
end;
end;
end;
procedure inittempansistrings;
var
hp : ptemprecord;
r : preference;
begin
hp:=templist;
while assigned(hp) do
begin
if hp^.temptype in [tt_ansistring,tt_freeansistring] then
begin
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
new(r);
reset_reference(r^);
r^.base:=procinfo^.framepointer;
r^.offset:=hp^.pos;
emit_const_ref(A_MOV,S_L,0,r);
end;
hp:=hp^.next;
end;
end;
procedure finalizetempansistrings;
var
hp : ptemprecord;
hr : treference;
begin
hp:=templist;
while assigned(hp) do
begin
if hp^.temptype in [tt_ansistring,tt_freeansistring] then
begin
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
reset_reference(hr);
hr.base:=procinfo^.framepointer;
hr.offset:=hp^.pos;
emitpushreferenceaddr(hr);
emitcall('FPC_ANSISTR_DECR_REF');
end;
hp:=hp^.next;
end;
end;
procedure genentrycode(alist : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean;
stackframe:longint;
var parasize:longint;var nostackframe:boolean;
inlined : boolean);
{
Generates the entry code for a procedure
}
var
hs : string;
{$ifdef GDB}
stab_function_name : Pai_stab_function_name;
{$endif GDB}
hr : preference;
p : psymtable;
r : treference;
oldlist,
oldexprasmlist : paasmoutput;
again : pasmlabel;
i : longint;
begin
oldexprasmlist:=exprasmlist;
exprasmlist:=alist;
if (not inlined) and (aktprocsym^.definition^.proctypeoption=potype_proginit) then
begin
emitinsertcall('FPC_INITIALIZEUNITS');
if target_info.target=target_I386_WIN32 then
begin
new(hr);
reset_reference(hr^);
hr^.symbol:=newasmsymbol('U_SYSWIN32_ISCONSOLE');
if apptype=at_cui then
exprasmlist^.insert(new(paicpu,op_const_ref(A_MOV,S_B,
1,hr)))
else
exprasmlist^.insert(new(paicpu,op_const_ref(A_MOV,S_B,
0,hr)));
end;
oldlist:=exprasmlist;
exprasmlist:=new(paasmoutput,init);
p:=symtablestack;
while assigned(p) do
begin
p^.foreach({$ifndef TP}@{$endif}initialize_threadvar);
p:=p^.next;
end;
oldlist^.insertlist(exprasmlist);
dispose(exprasmlist,done);
exprasmlist:=oldlist;
end;
{ a constructor needs a help procedure }
if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
begin
if procinfo^._class^.is_class then
begin
exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel)));
emitinsertcall('FPC_NEW_CLASS');
end
else
begin
exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel)));
emitinsertcall('FPC_HELP_CONSTRUCTOR');
exprasmlist^.insert(new(paicpu,op_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI)));
end;
end;
{ don't load ESI, does the caller }
{ When message method contains self as a parameter,
we must load it into ESI }
If (po_containsself in aktprocsym^.definition^.procoptions) then
begin
new(hr);
reset_reference(hr^);
hr^.offset:=procinfo^.ESI_offset;
hr^.base:=procinfo^.framepointer;
exprasmlist^.insert(new(paicpu,op_ref_reg(A_MOV,S_L,hr,R_ESI)));
end;
{ should we save edi,esi,ebx like C ? }
if (po_savestdregs in aktprocsym^.definition^.procoptions) then
begin
if (aktprocsym^.definition^.usedregisters and ($80 shr byte(R_EBX)))<>0 then
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EBX)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_ESI)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EDI)));
end;
{ for the save all registers we can simply use a pusha,popa which
push edi,esi,ebp,esp(ignored),ebx,edx,ecx,eax }
if (po_saveregisters in aktprocsym^.definition^.procoptions) then
begin
exprasmlist^.insert(new(paicpu,op_none(A_PUSHA,S_L)));
end;
{ omit stack frame ? }
if not inlined then
if procinfo^.framepointer=stack_pointer then
begin
CGMessage(cg_d_stackframe_omited);
nostackframe:=true;
if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
parasize:=0
else
parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.call_offset-4;
if stackframe<>0 then
exprasmlist^.insert(new(paicpu,
op_const_reg(A_SUB,S_L,gettempsize,R_ESP)));
end
else
begin
if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
parasize:=0
else
parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.call_offset-8;
nostackframe:=false;
if stackframe<>0 then
begin
{$ifdef unused}
if (cs_littlesize in aktglobalswitches) and (stackframe<=65535) then
begin
if (cs_check_stack in aktlocalswitches) and
not(target_info.target in [target_i386_linux,target_i386_win32]) then
begin
emitinsertcall('FPC_STACKCHECK');
exprasmlist^.insert(new(paicpu,op_const(A_PUSH,S_L,stackframe)));
end;
if cs_profile in aktmoduleswitches then
genprofilecode;
{ %edi is already saved when pocdecl is used
if (target_info.target=target_linux) and
((aktprocsym^.definition^.options and poexports)<>0) then
exprasmlist^.insert(new(Paicpu,op_reg(A_PUSH,S_L,R_EDI))); }
exprasmlist^.insert(new(paicpu,op_const_const(A_ENTER,S_NO,stackframe,0)))
end
else
{$endif unused}
begin
{ windows guards only a few pages for stack growing, }
{ so we have to access every page first }
if (target_os.id=os_i386_win32) and
(stackframe>=winstackpagesize) then
begin
if stackframe div winstackpagesize<=5 then
begin
exprasmlist^.insert(new(paicpu,op_const_reg(A_SUB,S_L,stackframe-4,R_ESP)));
for i:=1 to stackframe div winstackpagesize do
begin
hr:=new_reference(R_ESP,stackframe-i*winstackpagesize);
exprasmlist^.concat(new(paicpu,
op_const_ref(A_MOV,S_L,0,hr)));
end;
exprasmlist^.concat(new(paicpu,
op_reg(A_PUSH,S_L,R_EAX)));
end
else
begin
getlabel(again);
exprasmlist^.concat(new(paicpu,
op_const_reg(A_MOV,S_L,stackframe div winstackpagesize,R_EDI)));
emitlab(again);
exprasmlist^.concat(new(paicpu,
op_const_reg(A_SUB,S_L,winstackpagesize-4,R_ESP)));
exprasmlist^.concat(new(paicpu,
op_reg(A_PUSH,S_L,R_EAX)));
exprasmlist^.concat(new(paicpu,
op_reg(A_DEC,S_L,R_EDI)));
emitjmp(C_NZ,again);
exprasmlist^.concat(new(paicpu,
op_const_reg(A_SUB,S_L,stackframe mod winstackpagesize,R_ESP)));
end
end
else
exprasmlist^.insert(new(paicpu,op_const_reg(A_SUB,S_L,stackframe,R_ESP)));
if (cs_check_stack in aktlocalswitches) and
not(target_info.target in [target_i386_linux,target_i386_win32]) then
begin
emitinsertcall('FPC_STACKCHECK');
exprasmlist^.insert(new(paicpu,op_const(A_PUSH,S_L,stackframe)));
end;
if cs_profile in aktmoduleswitches then
genprofilecode;
exprasmlist^.insert(new(paicpu,op_reg_reg(A_MOV,S_L,R_ESP,R_EBP)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EBP)));
end;
end { endif stackframe <> 0 }
else
begin
if cs_profile in aktmoduleswitches then
genprofilecode;
exprasmlist^.insert(new(paicpu,op_reg_reg(A_MOV,S_L,R_ESP,R_EBP)));
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_EBP)));
end;
end;
if (po_interrupt in aktprocsym^.definition^.procoptions) then
generate_interrupt_stackframe_entry;
{ initialize return value }
if (procinfo^.retdef<>pdef(voiddef)) and
(procinfo^.retdef^.needs_inittable) and
((procinfo^.retdef^.deftype<>objectdef) or
not(pobjectdef(procinfo^.retdef)^.is_class)) then
begin
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
reset_reference(r);
r.offset:=procinfo^.retoffset;
r.base:=procinfo^.framepointer;
initialize(procinfo^.retdef,r,ret_in_param(procinfo^.retdef));
end;
{ generate copies of call by value parameters }
if not(po_assembler in aktprocsym^.definition^.procoptions) then
aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}copyvalueparas);
{ initialisizes local data }
aktprocsym^.definition^.localst^.foreach({$ifndef TP}@{$endif}initialize_data);
{ add a reference to all call by value/const parameters }
aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}incr_data);
{ initilisizes temp. ansi/wide string data }
inittempansistrings;
{ do we need an exception frame because of ansi/widestrings ? }
if (procinfo^.flags and pi_needs_implicit_finally)<>0 then
begin
usedinproc:=usedinproc or ($80 shr byte(R_EAX));
{ Type of stack-frame must be pushed}
exprasmlist^.concat(new(paicpu,op_const(A_PUSH,S_L,1)));
emitcall('FPC_PUSHEXCEPTADDR');
exprasmlist^.concat(new(paicpu,
op_reg(A_PUSH,S_L,R_EAX)));
emitcall('FPC_SETJMP');
exprasmlist^.concat(new(paicpu,
op_reg(A_PUSH,S_L,R_EAX)));
exprasmlist^.concat(new(paicpu,
op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
emitjmp(C_NE,aktexitlabel);
end;
if (cs_profile in aktmoduleswitches) or
(aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or
(assigned(procinfo^._class) and (procinfo^._class^.owner^.symtabletype=globalsymtable)) then
make_global:=true;
if not inlined then
begin
hs:=proc_names.get;
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) then
exprasmlist^.insert(new(pai_force_line,init));
if (cs_debuginfo in aktmoduleswitches) and target_os.use_function_relative_addresses then
stab_function_name := new(pai_stab_function_name,init(strpnew(hs)));
{$EndIf GDB}
while hs<>'' do
begin
if make_global then
exprasmlist^.insert(new(pai_symbol,initname_global(hs,0)))
else
exprasmlist^.insert(new(pai_symbol,initname(hs,0)));
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and
target_os.use_function_relative_addresses then
exprasmlist^.insert(new(pai_stab_function_name,init(strpnew(hs))));
{$endif GDB}
hs:=proc_names.get;
end;
end;
{$ifdef GDB}
if (not inlined) and (cs_debuginfo in aktmoduleswitches) then
begin
if target_os.use_function_relative_addresses then
exprasmlist^.insert(stab_function_name);
if make_global or ((procinfo^.flags and pi_is_global) <> 0) then
aktprocsym^.is_global := True;
exprasmlist^.insert(new(pai_stabs,init(aktprocsym^.stabstring)));
aktprocsym^.isstabwritten:=true;
end;
{$endif GDB}
{ Align }
if (not inlined) then
begin
{ gprof uses 16 byte granularity !! }
if (cs_profile in aktmoduleswitches) then
exprasmlist^.insert(new(pai_align,init_op(16,$90)))
else
if not(cs_littlesize in aktglobalswitches) then
exprasmlist^.insert(new(pai_align,init_op(16,$90)));
end;
exprasmlist:=oldexprasmlist;
end;
procedure handle_return_value(inlined : boolean);
var
hr : preference;
op : Tasmop;
s : Topsize;
begin
if procinfo^.retdef<>pdef(voiddef) then
begin
if ((procinfo^.flags and pi_operator)<>0) and
assigned(opsym) then
procinfo^.funcret_is_valid:=
procinfo^.funcret_is_valid or (opsym^.refs>0);
if not(procinfo^.funcret_is_valid) and not inlined { and
((procinfo^.flags and pi_uses_asm)=0)} then
CGMessage(sym_w_function_result_not_set);
hr:=new_reference(procinfo^.framepointer,procinfo^.retoffset);
if (procinfo^.retdef^.deftype in [orddef,enumdef]) then
begin
case procinfo^.retdef^.size of
8:
begin
emit_ref_reg(A_MOV,S_L,hr,R_EAX);
hr:=new_reference(procinfo^.framepointer,procinfo^.retoffset+4);
emit_ref_reg(A_MOV,S_L,hr,R_EDX);
end;
4:
emit_ref_reg(A_MOV,S_L,hr,R_EAX);
2:
emit_ref_reg(A_MOV,S_W,hr,R_AX);
1:
emit_ref_reg(A_MOV,S_B,hr,R_AL);
end;
end
else
if ret_in_acc(procinfo^.retdef) then
emit_ref_reg(A_MOV,S_L,hr,R_EAX)
else
if (procinfo^.retdef^.deftype=floatdef) then
begin
floatloadops(pfloatdef(procinfo^.retdef)^.typ,op,s);
exprasmlist^.concat(new(paicpu,op_ref(op,s,hr)))
end
else
dispose(hr);
end
end;
procedure genexitcode(alist : paasmoutput;parasize:longint;nostackframe,inlined:boolean);
var
{$ifdef GDB}
mangled_length : longint;
p : pchar;
{$endif GDB}
nofinal,okexitlabel,noreraiselabel : pasmlabel;
hr : treference;
oldexprasmlist : paasmoutput;
ai : paicpu;
begin
oldexprasmlist:=exprasmlist;
exprasmlist:=alist;
if aktexitlabel^.is_used then
exprasmlist^.insert(new(pai_label,init(aktexitlabel)));
{ call the destructor help procedure }
if (aktprocsym^.definition^.proctypeoption=potype_destructor) then
begin
if procinfo^._class^.is_class then
begin
emitinsertcall('FPC_DISPOSE_CLASS');
end
else
begin
emitinsertcall('FPC_HELP_DESTRUCTOR');
exprasmlist^.insert(new(paicpu,op_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI)));
{ must the object be finalized ? }
if procinfo^._class^.needs_inittable then
begin
getlabel(nofinal);
exprasmlist^.insert(new(pai_label,init(nofinal)));
emitinsertcall('FPC_FINALIZE');
exprasmlist^.insert(new(paicpu,op_reg(A_PUSH,S_L,R_ESI)));
exprasmlist^.insert(new(paicpu,op_sym(A_PUSH,S_L,procinfo^._class^.get_inittable_label)));
ai:=new(paicpu,op_sym(A_Jcc,S_NO,nofinal));
ai^.SetCondition(C_Z);
exprasmlist^.insert(ai);
reset_reference(hr);
hr.base:=R_EBP;
hr.offset:=8;
exprasmlist^.insert(new(paicpu,op_const_ref(A_CMP,S_L,0,newreference(hr))));
end;
end;
end;
{ finalize temporary data }
finalizetempansistrings;
{ finalize local data }
aktprocsym^.definition^.localst^.foreach({$ifndef TP}@{$endif}finalize_data);
{ finalize paras data }
if assigned(aktprocsym^.definition^.parast) then
aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}finalize_data);
{ do we need to handle exceptions because of ansi/widestrings ? }
if (procinfo^.flags and pi_needs_implicit_finally)<>0 then
begin
getlabel(noreraiselabel);
emitcall('FPC_POPADDRSTACK');
exprasmlist^.concat(new(paicpu,
op_reg(A_POP,S_L,R_EAX)));
exprasmlist^.concat(new(paicpu,
op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
emitjmp(C_E,noreraiselabel);
{ must be the return value finalized before reraising the exception? }
if (procinfo^.retdef<>pdef(voiddef)) and
(procinfo^.retdef^.needs_inittable) and
((procinfo^.retdef^.deftype<>objectdef) or
not(pobjectdef(procinfo^.retdef)^.is_class)) then
begin
reset_reference(hr);
hr.offset:=procinfo^.retoffset;
hr.base:=procinfo^.framepointer;
finalize(procinfo^.retdef,hr,ret_in_param(procinfo^.retdef));
end;
emitcall('FPC_RERAISE');
emitlab(noreraiselabel);
end;
{ call __EXIT for main program }
if (not DLLsource) and (not inlined) and (aktprocsym^.definition^.proctypeoption=potype_proginit) then
begin
emitcall('FPC_DO_EXIT');
end;
{ handle return value }
if not(po_assembler in aktprocsym^.definition^.procoptions) then
if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then
handle_return_value(inlined)
else
begin
{ successful constructor deletes the zero flag }
{ and returns self in eax }
{ eax must be set to zero if the allocation failed !!! }
getlabel(okexitlabel);
emitjmp(C_NONE,okexitlabel);
emitlab(faillabel);
emit_ref_reg(A_MOV,S_L,new_reference(procinfo^.framepointer,12),R_ESI);
emit_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI);
emitcall('FPC_HELP_FAIL');
emitlab(okexitlabel);
emit_reg_reg(A_MOV,S_L,R_ESI,R_EAX);
emit_reg_reg(A_OR,S_L,R_EAX,R_EAX);
end;
{ stabs uses the label also ! }
if aktexit2label^.is_used or
((cs_debuginfo in aktmoduleswitches) and not inlined) then
emitlab(aktexit2label);
{ gives problems for long mangled names }
{list^.concat(new(pai_symbol,init(aktprocsym^.definition^.mangledname+'_end')));}
{ should we restore edi ? }
{ for all i386 gcc implementations }
if (po_savestdregs in aktprocsym^.definition^.procoptions) then
begin
if (aktprocsym^.definition^.usedregisters and ($80 shr byte(R_EBX)))<>0 then
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_EBX)));
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ESI)));
exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_EDI)));
{ here we could reset R_EBX
but that is risky because it only works
if genexitcode is called after genentrycode
so lets skip this for the moment PM
aktprocsym^.definition^.usedregisters:=
aktprocsym^.definition^.usedregisters or not ($80 shr byte(R_EBX));
}
end;
{ for the save all registers we can simply use a pusha,popa which
push edi,esi,ebp,esp(ignored),ebx,edx,ecx,eax }
if (po_saveregisters in aktprocsym^.definition^.procoptions) then
begin
exprasmlist^.concat(new(paicpu,op_none(A_POPA,S_L)));
end;
if not(nostackframe) then
begin
if not inlined then
exprasmlist^.concat(new(paicpu,op_none(A_LEAVE,S_NO)));
end
else
begin
if (gettempsize<>0) and not inlined then
exprasmlist^.insert(new(paicpu,
op_const_reg(A_ADD,S_L,gettempsize,R_ESP)));
end;
{ parameters are limited to 65535 bytes because }
{ ret allows only imm16 }
if (parasize>65535) and not(pocall_clearstack in aktprocsym^.definition^.proccalloptions) then
CGMessage(cg_e_parasize_too_big);
{ at last, the return is generated }
if not inlined then
if (po_interrupt in aktprocsym^.definition^.procoptions) then
generate_interrupt_stackframe_exit
else
begin
{Routines with the poclearstack flag set use only a ret.}
{ also routines with parasize=0 }
if (parasize=0) or (pocall_clearstack in aktprocsym^.definition^.proccalloptions) then
exprasmlist^.concat(new(paicpu,op_none(A_RET,S_NO)))
else
exprasmlist^.concat(new(paicpu,op_const(A_RET,S_NO,parasize)));
end;
exprasmlist^.concat(new(pai_symbol_end,initname(aktprocsym^.definition^.mangledname)));
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and not inlined then
begin
aktprocsym^.concatstabto(exprasmlist);
if assigned(procinfo^._class) then
if (not assigned(procinfo^.parent) or
not assigned(procinfo^.parent^._class)) then
exprasmlist^.concat(new(pai_stabs,init(strpnew(
'"$t:v'+procinfo^._class^.numberstring+'",'+
tostr(N_PSYM)+',0,0,'+tostr(procinfo^.esi_offset)))))
else
exprasmlist^.concat(new(pai_stabs,init(strpnew(
'"$t:r'+procinfo^._class^.numberstring+'",'+
tostr(N_RSYM)+',0,0,'+tostr(GDB_i386index[R_ESI])))));
if (pdef(aktprocsym^.definition^.retdef) <> pdef(voiddef)) then
begin
if ret_in_param(aktprocsym^.definition^.retdef) then
exprasmlist^.concat(new(pai_stabs,init(strpnew(
'"'+aktprocsym^.name+':X*'+aktprocsym^.definition^.retdef^.numberstring+'",'+
tostr(N_PSYM)+',0,0,'+tostr(procinfo^.retoffset)))))
else
exprasmlist^.concat(new(pai_stabs,init(strpnew(
'"'+aktprocsym^.name+':X'+aktprocsym^.definition^.retdef^.numberstring+'",'+
tostr(N_PSYM)+',0,0,'+tostr(procinfo^.retoffset)))));
if (m_result in aktmodeswitches) then
if ret_in_param(aktprocsym^.definition^.retdef) then
exprasmlist^.concat(new(pai_stabs,init(strpnew(
'"RESULT:X*'+aktprocsym^.definition^.retdef^.numberstring+'",'+
tostr(N_PSYM)+',0,0,'+tostr(procinfo^.retoffset)))))
else
exprasmlist^.concat(new(pai_stabs,init(strpnew(
'"RESULT:X'+aktprocsym^.definition^.retdef^.numberstring+'",'+
tostr(N_PSYM)+',0,0,'+tostr(procinfo^.retoffset)))));
end;
mangled_length:=length(aktprocsym^.definition^.mangledname);
getmem(p,mangled_length+50);
strpcopy(p,'192,0,0,');
strpcopy(strend(p),aktprocsym^.definition^.mangledname);
exprasmlist^.concat(new(pai_stabn,init(strnew(p))));
{list^.concat(new(pai_stabn,init(strpnew('192,0,0,'
+aktprocsym^.definition^.mangledname))));
p[0]:='2';p[1]:='2';p[2]:='4';
strpcopy(strend(p),'_end');}
freemem(p,mangled_length+50);
exprasmlist^.concat(new(pai_stabn,init(
strpnew('224,0,0,'+aktexit2label^.name))));
{ strpnew('224,0,0,'
+aktprocsym^.definition^.mangledname+'_end'))));}
end;
{$endif GDB}
exprasmlist:=oldexprasmlist;
end;
{$ifdef test_dest_loc}
procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
begin
if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then
begin
emit_reg_reg(A_MOV,s,reg,dest_loc.register);
set_location(p^.location,dest_loc);
in_dest_loc:=true;
end
else
if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then
begin
exprasmlist^.concat(new(paicpu,op_reg_ref(A_MOV,s,reg,newreference(dest_loc.reference))));
set_location(p^.location,dest_loc);
in_dest_loc:=true;
end
else
internalerror(20080);
end;
{$endif test_dest_loc}
end.
{
$Log$
Revision 1.50 1999-09-29 11:46:18 florian
* fixed bug 292 from bugs directory
Revision 1.49 1999/09/28 21:07:53 florian
* fixed bug 608
Revision 1.48 1999/09/28 19:43:47 florian
* the maybe_push fix of Pierre wasn't 100%, the tree parameter
must contain a valid location (which is saved if necessary)
Revision 1.47 1999/09/27 23:44:50 peter
* procinfo is now a pointer
* support for result setting in sub procedure
Revision 1.46 1999/09/26 13:26:07 florian
* exception patch of Romio nevertheless the excpetion handling
needs some corections regarding register saving
* gettempansistring is again a procedure
Revision 1.45 1999/09/20 16:35:43 peter
* restored old alignment, saves 40k on ppc386
Revision 1.44 1999/09/16 07:58:14 pierre
+ RESULT pseudo var added in GDB debug info
Revision 1.43 1999/09/15 20:35:38 florian
* small fix to operator overloading when in MMX mode
+ the compiler uses now fldz and fld1 if possible
+ some fixes to floating point registers
+ some math. functions (arctan, ln, sin, cos, sqrt, sqr, pi) are now inlined
* .... ???
Revision 1.42 1999/09/14 07:59:47 florian
* finally!? fixed
with <function with result in temp> do
My last and also Peter's fix before were wrong :(
Revision 1.41 1999/09/12 08:48:04 florian
* bugs 593 and 607 fixed
* some other potential bugs with array constructors fixed
* for classes compiled in $M+ and it's childs, the default access method
is now published
* fixed copyright message (it is now 1993-99)
Revision 1.40 1999/09/11 11:23:58 florian
* bug 603 fixed
Revision 1.39 1999/09/10 15:42:51 peter
* fixed with <calln> do
* fixed finalize/initialize call for new/dispose
Revision 1.38 1999/09/04 20:50:08 florian
* bug 580 fixed
Revision 1.37 1999/09/02 17:07:38 florian
* problems with -Or fixed: tdef.isfpuregable was wrong!
Revision 1.36 1999/09/01 09:26:23 peter
* fixed temp allocation for arrayconstructor
Revision 1.35 1999/08/30 12:00:44 pierre
* problem with maybe_push/restore solved hopefully
Revision 1.34 1999/08/30 09:41:31 pierre
* last change undone because cycle was broken
Revision 1.33 1999/08/28 17:48:34 peter
* fixed crash in restore
Revision 1.32 1999/08/28 15:34:17 florian
* bug 519 fixed
Revision 1.31 1999/08/25 11:59:55 jonas
* changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu)
Revision 1.30 1999/08/19 13:06:45 pierre
* _FAIL will now free memory correctly
and reset VMT field on static instances
(not yet tested for classes, is it allowed ?)
+ emit_.... all variant defined here to avoid tons of
exprasmlist^.concat(new(paicpu,...) in cg386***
Revision 1.29 1999/08/14 00:36:07 peter
* array constructor support
Revision 1.28 1999/08/07 14:20:57 florian
* some small problems fixed
Revision 1.27 1999/08/05 23:45:09 peter
* saveregister is now working and used for assert and iocheck (which has
been moved to system.inc because it's now system independent)
Revision 1.26 1999/08/05 14:58:04 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.25 1999/08/04 13:45:24 florian
+ floating point register variables !!
* pairegalloc is now generated for register variables
Revision 1.24 1999/08/04 00:22:55 florian
* renamed i386asm and i386base to cpuasm and cpubase
Revision 1.23 1999/08/03 22:02:49 peter
* moved bitmask constants to sets
* some other type/const renamings
Revision 1.22 1999/08/01 23:36:39 florian
* some changes to compile the new code generator
Revision 1.21 1999/08/01 17:32:31 florian
* more fixes for inittable call
Revision 1.20 1999/08/01 17:17:37 florian
* tried to fix a bug with init table
Revision 1.19 1999/07/29 20:53:58 peter
* write .size also
Revision 1.18 1999/07/26 12:13:46 florian
* exit in try..finally blocks needed a second fix
* a raise in a try..finally lead into a endless loop, fixed
Revision 1.17 1999/07/22 09:37:38 florian
+ resourcestring implemented
+ start of longstring support
Revision 1.16 1999/07/18 10:41:59 florian
* fix of my previous commit nevertheless it doesn't work completly
Revision 1.15 1999/07/18 10:19:44 florian
* made it compilable with Dlephi 4 again
+ fixed problem with large stack allocations on win32
Revision 1.14 1999/07/06 21:48:11 florian
* a lot bug fixes:
- po_external isn't any longer necessary for procedure compatibility
- m_tp_procvar is in -Sd now available
- error messages of procedure variables improved
- return values with init./finalization fixed
- data types with init./finalization aren't any longer allowed in variant
record
Revision 1.13 1999/07/05 20:25:22 peter
* merged
Revision 1.12 1999/07/05 20:13:13 peter
* removed temp defines
Revision 1.11 1999/07/05 11:56:56 jonas
* merged
Revision 1.5.2.5 1999/07/05 20:03:31 peter
* removed warning/notes
Revision 1.5.2.3 1999/07/04 21:50:17 jonas
* everything between $ifdef jmpfix:
* when a jxx instruction is disposed, decrease the refcount of the label
it referenced
* for jmp instructions to a label, set is_jmp also to true (was only done
for Jcc instructions)
Revision 1.9 1999/07/01 15:49:11 florian
* int64/qword type release
+ lo/hi for int64/qword
Revision 1.8 1999/06/28 22:29:15 florian
* qword division fixed
+ code for qword/int64 type casting added:
range checking isn't implemented yet
Revision 1.7 1999/06/17 13:19:50 pierre
* merged from 0_99_12 branch
Revision 1.5.2.2 1999/06/17 12:38:39 pierre
* wrong warning for operators removed
Revision 1.6 1999/06/14 17:47:48 peter
* merged
Revision 1.5.2.1 1999/06/14 17:27:08 peter
* fixed posavestd regs which popped at the wrong place
Revision 1.5 1999/06/03 16:21:15 pierre
* fixes a bug due to int64 code in maybe_savetotemp
Revision 1.4 1999/06/02 22:44:06 pierre
* previous wrong log corrected
Revision 1.3 1999/06/02 22:25:29 pierre
* changed $ifdef FPC @ into $ifndef TP
Revision 1.2 1999/06/02 10:11:49 florian
* make cycle fixed i.e. compilation with 0.99.10
* some fixes for qword
* start of register calling conventions
Revision 1.1 1999/06/01 19:33:18 peter
* reinserted
Revision 1.158 1999/06/01 14:45:46 peter
* @procvar is now always needed for FPC
Revision 1.157 1999/05/27 19:44:20 peter
* removed oldasm
* plabel -> pasmlabel
* -a switches to source writing automaticly
* assembler readers OOPed
* asmsymbol automaticly external
* jumptables and other label fixes for asm readers
Revision 1.156 1999/05/24 08:55:24 florian
* non working safecall directiv implemented, I don't know if we
need it
Revision 1.155 1999/05/23 19:55:14 florian
* qword/int64 multiplication fixed
+ qword/int64 subtraction
Revision 1.154 1999/05/23 18:42:05 florian
* better error recovering in typed constants
* some problems with arrays of const fixed, some problems
due my previous
- the location type of array constructor is now LOC_MEM
- the pushing of high fixed
- parameter copying fixed
- zero temp. allocation removed
* small problem in the assembler writers fixed:
ref to nil wasn't written correctly
Revision 1.153 1999/05/21 13:54:55 peter
* NEWLAB for label as symbol
Revision 1.152 1999/05/19 22:00:45 florian
* some new routines for register management:
maybe_savetotemp,restorefromtemp, saveusedregisters,
restoreusedregisters
Revision 1.151 1999/05/19 20:40:11 florian
* fixed a couple of array related bugs:
- var a : array[0..1] of char; p : pchar; p:=a+123; works now
- open arrays with an odd size doesn't work: movsb wasn't generated
- introduced some new array type helper routines (is_special_array) etc.
- made the array type checking in isconvertable more strict, often
open array can be used where is wasn't allowed etc...
Revision 1.150 1999/05/19 15:26:30 florian
* if a non local variables isn't initialized the compiler doesn't write
any longer "local var. seems not to be ..."
Revision 1.149 1999/05/19 13:59:07 jonas
* no more "enter" generated when -Og is used (caused sometimes crashes under
Linux, don't know why)
Revision 1.148 1999/05/18 21:58:30 florian
* fixed some bugs related to temp. ansistrings and functions results
which return records/objects/arrays which need init/final.
Revision 1.147 1999/05/18 14:15:28 peter
* containsself fixes
* checktypes()
Revision 1.146 1999/05/17 22:42:26 florian
* FPC_ANSISTR_DECR_REF needs a reference!
Revision 1.145 1999/05/17 21:57:06 florian
* new temporary ansistring handling
Revision 1.144 1999/05/15 21:33:18 peter
* redesigned temp_gen temp allocation so temp allocation for
ansistring works correct. It also does a best fit instead of first fit
Revision 1.143 1999/05/13 21:59:22 peter
* removed oldppu code
* warning if objpas is loaded from uses
* first things for new deref writing
Revision 1.142 1999/05/12 00:19:46 peter
* removed R_DEFAULT_SEG
* uniform float names
Revision 1.141 1999/05/07 00:33:44 pierre
explicit type conv to pobject checked with cond TESTOBJEXT2
Revision 1.140 1999/05/06 09:05:17 peter
* generic write_float and str_float
* fixed constant float conversions
Revision 1.139 1999/05/04 21:44:35 florian
* changes to compile it with Delphi 4.0
Revision 1.138 1999/05/02 09:35:36 florian
+ method message handlers which contain an explicit self can't be called
directly anymore
+ self is now loaded at the start of the an message handler with an explicit
self
+ $useoverlay fixed: i386 was renamed to i386base
Revision 1.137 1999/05/01 13:24:16 peter
* merged nasm compiler
* old asm moved to oldasm/
Revision 1.136 1999/04/28 06:01:56 florian
* changes of Bruessel:
+ message handler can now take an explicit self
* typinfo fixed: sometimes the type names weren't written
* the type checking for pointer comparisations and subtraction
and are now more strict (was also buggy)
* small bug fix to link.pas to support compiling on another
drive
* probable bug in popt386 fixed: call/jmp => push/jmp
transformation didn't count correctly the jmp references
+ threadvar support
* warning if ln/sqrt gets an invalid constant argument
Revision 1.135 1999/04/26 13:31:26 peter
* release storenumber,double_checksum
Revision 1.134 1999/04/21 21:53:08 pierre
* previous log corrected
Revision 1.133 1999/04/21 16:31:38 pierre
+ TEMPS_NOT_PUSH conditional code :
put needed registers into temp space instead of pushing them
Revision 1.132 1999/04/21 09:43:30 peter
* storenumber works
* fixed some typos in double_checksum
+ incompatible types type1 and type2 message (with storenumber)
Revision 1.131 1999/04/19 09:45:49 pierre
+ cdecl or stdcall push all args with longint size
* tempansi stuff cleaned up
Revision 1.130 1999/04/17 13:14:50 peter
* concat_external added for new init/final
Revision 1.129 1999/04/16 20:44:35 florian
* the boolean operators =;<>;xor with LOC_JUMP and LOC_FLAGS
operands fixed, small things for new ansistring management
Revision 1.128 1999/04/16 13:42:31 jonas
* more regalloc fixes (still not complete)
Revision 1.127 1999/04/16 10:28:23 pierre
+ added posavestdregs used for cdecl AND stdcall functions
(saves ESI EDI and EBX for i386)
Revision 1.126 1999/04/16 09:56:06 pierre
* unused local var commented
Revision 1.125 1999/04/15 13:08:30 pierre
* misplaced statement in concatcopy corrected
Revision 1.124 1999/04/15 12:19:55 peter
+ finalization support
Revision 1.123 1999/04/09 00:00:52 pierre
+ uses ungetiftempansi
Revision 1.122 1999/04/08 15:57:47 peter
+ subrange checking for readln()
Revision 1.121 1999/03/31 13:55:08 peter
* assembler inlining working for ag386bin
Revision 1.120 1999/03/26 00:05:27 peter
* released valintern
+ deffile is now removed when compiling is finished
* ^( compiles now correct
+ static directive
* shrd fixed
Revision 1.119 1999/03/24 23:16:55 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.118 1999/03/16 17:52:49 jonas
* changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
* in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
* in cgai386: also small fixes to emitrangecheck
Revision 1.117 1999/03/09 19:29:12 peter
* ecxpushed was not reset in concatcopy
Revision 1.116 1999/03/09 11:45:40 pierre
* small arrays and records (size <=4) are copied directly
Revision 1.115 1999/03/03 12:15:13 pierre
* U_SYSWIN32_ISCONSOLE adde to external list
Revision 1.114 1999/03/02 18:21:33 peter
+ flags support for add and case
Revision 1.113 1999/03/01 15:46:19 peter
* ag386bin finally make cycles correct
* prefixes are now also normal opcodes
Revision 1.112 1999/03/01 13:39:44 pierre
* temp for int_value const parameters
Revision 1.111 1999/02/25 21:02:32 peter
* ag386bin updates
+ coff writer
Revision 1.110 1999/02/22 02:15:17 peter
* updates for ag386bin
Revision 1.109 1999/02/16 00:46:09 peter
* optimized concatcopy with ecx=1 and ecx=0
Revision 1.108 1999/02/15 13:13:14 pierre
* fix for bug0216
Revision 1.107 1999/02/12 10:43:58 florian
* internal error 10 with ansistrings fixed
Revision 1.106 1999/02/03 09:50:22 pierre
* conditional code to try to release temp for consts that are not in memory
Revision 1.105 1999/02/02 11:47:56 peter
* fixed ansi2short
Revision 1.104 1999/01/25 09:29:36 florian
* very rare problem with in-operator fixed, mainly it was a problem of
emit_to_reg32 (typo in case ranges)
Revision 1.103 1999/01/21 22:10:42 peter
* fixed array of const
* generic platform independent high() support
Revision 1.102 1999/01/19 10:19:00 florian
* bug with mul. of dwords fixed, reported by Alexander Stohr
* some changes to compile with TP
+ small enhancements for the new code generator
Revision 1.101 1999/01/15 11:36:48 pierre
* double temp disallocation on ansistring removed
Revision 1.100 1998/12/30 13:41:08 peter
* released valuepara
Revision 1.99 1998/12/22 13:11:00 florian
* memory leaks for ansistring type casts fixed
Revision 1.98 1998/12/19 00:23:46 florian
* ansistring memory leaks fixed
Revision 1.97 1998/12/11 16:10:08 florian
+ shifting for 64 bit ints added
* bug in getexplicitregister32 fixed: usableregs wasn't decremented !!
Revision 1.96 1998/12/11 00:03:11 peter
+ globtype,tokens,version unit splitted from globals
Revision 1.95 1998/12/10 09:47:19 florian
+ basic operations with int64/qord (compiler with -dint64)
+ rtti of enumerations extended: names are now written
Revision 1.94 1998/12/03 10:17:27 peter
* target_os.use_bound_instruction boolean
Revision 1.93 1998/11/30 19:48:56 peter
* some more rangecheck fixes
Revision 1.92 1998/11/30 16:34:44 pierre
* corrected problems with rangecheck
+ added needed code for no rangecheck in CRC32 functions in ppu unit
* enumdef lso need its rangenr reset to zero
when calling reset_global_defs
Revision 1.91 1998/11/30 09:43:07 pierre
* some range check bugs fixed (still not working !)
+ added DLL writing support for win32 (also accepts variables)
+ TempAnsi for code that could be used for Temporary ansi strings
handling
Revision 1.90 1998/11/29 12:43:45 peter
* commented the fpc_init_stack_check becuase it is not in the RTL
Revision 1.89 1998/11/27 14:50:34 peter
+ open strings, $P switch support
Revision 1.88 1998/11/26 21:33:07 peter
* rangecheck updates
Revision 1.87 1998/11/26 13:10:41 peter
* new int - int conversion -dNEWCNV
* some function renamings
Revision 1.86 1998/11/26 09:53:37 florian
* for classes no init/final. code is necessary, fixed
Revision 1.85 1998/11/20 15:35:56 florian
* problems with rtti fixed, hope it works
Revision 1.84 1998/11/18 17:45:25 peter
* fixes for VALUEPARA
Revision 1.83 1998/11/18 15:44:12 peter
* VALUEPARA for tp7 compatible value parameters
Revision 1.82 1998/11/17 00:36:41 peter
* more ansistring fixes
Revision 1.81 1998/11/16 19:23:33 florian
* isconsole is now set by win32 applications
Revision 1.80 1998/11/16 15:35:40 peter
* rename laod/copystring -> load/copyshortstring
* fixed int-bool cnv bug
+ char-ansistring conversion
Revision 1.79 1998/11/16 11:28:56 pierre
* stackcheck removed for i386_win32
* exportlist does not crash at least !!
(was need for tests dir !)z
Revision 1.78 1998/11/15 16:32:34 florian
* some stuff of Pavel implement (win32 dll creation)
* bug with ansistring function results fixed
Revision 1.77 1998/11/13 15:40:17 pierre
+ added -Se in Makefile cvstest target
+ lexlevel cleanup
normal_function_level main_program_level and unit_init_level defined
* tins_cache grown to A_EMMS (gave range check error in asm readers)
(test added in code !)
* -Un option was wrong
* _FAIL and _SELF only keyword inside
constructors and methods respectively
Revision 1.76 1998/11/12 16:43:33 florian
* functions with ansi strings as result didn't work, solved
Revision 1.75 1998/11/12 11:19:44 pierre
* fix for first line of function break
Revision 1.74 1998/11/12 09:46:18 pierre
+ break main stops before calls to unit inits
+ break at constructors stops before call to FPC_NEW_CLASS
or FPC_HELP_CONSTRUCTOR
Revision 1.73 1998/11/10 10:50:55 pierre
* temporary fix for long mangled procsym names
Revision 1.72 1998/11/05 12:02:40 peter
* released useansistring
* removed -Sv, its now available in fpc modes
Revision 1.71 1998/10/29 15:42:45 florian
+ partial disposing of temp. ansistrings
Revision 1.70 1998/10/25 23:32:49 peter
* fixed unsigned mul
Revision 1.69 1998/10/20 13:11:33 peter
+ def_getreg to get a register with the same size as definition
Revision 1.68 1998/10/20 08:06:48 pierre
* several memory corruptions due to double freemem solved
=> never use p^.loc.location:=p^.left^.loc.location;
+ finally I added now by default
that ra386dir translates global and unit symbols
+ added a first field in tsymtable and
a nextsym field in tsym
(this allows to obtain ordered type info for
records and objects in gdb !)
Revision 1.67 1998/10/16 13:12:50 pierre
* added vmt_offsets in destructors code also !!!
* vmt_offset code for m68k
Revision 1.66 1998/10/16 08:48:40 peter
* fixed some misplaced $endif GDB
Revision 1.65 1998/10/15 12:37:40 pierre
+ passes vmt offset to HELP_CONSTRUCTOR for objects
Revision 1.64 1998/10/13 16:50:13 pierre
* undid some changes of Peter that made the compiler wrong
for m68k (I had to reinsert some ifdefs)
* removed several memory leaks under m68k
* removed the meory leaks for assembler readers
* cross compiling shoud work again better
( crosscompiling sysamiga works
but as68k still complain about some code !)
Revision 1.63 1998/10/13 13:10:13 peter
* new style for m68k/i386 infos and enums
Revision 1.62 1998/10/08 17:17:17 pierre
* current_module old scanner tagged as invalid if unit is recompiled
+ added ppheap for better info on tracegetmem of heaptrc
(adds line column and file index)
* several memory leaks removed ith help of heaptrc !!
Revision 1.61 1998/10/08 13:48:41 peter
* fixed memory leaks for do nothing source
* fixed unit interdependency
Revision 1.60 1998/10/07 10:37:43 peter
* fixed stabs
Revision 1.59 1998/10/06 17:16:45 pierre
* some memory leaks fixed (thanks to Peter for heaptrc !)
Revision 1.58 1998/10/05 21:33:16 peter
* fixed 161,165,166,167,168
Revision 1.57 1998/10/01 09:22:54 peter
* fixed value openarray
* ungettemp of arrayconstruct
Revision 1.56 1998/09/28 16:57:19 pierre
* changed all length(p^.value_str^) into str_length(p)
to get it work with and without ansistrings
* changed sourcefiles field of tmodule to a pointer
Revision 1.55 1998/09/28 16:18:15 florian
* two fixes to get ansi strings work
Revision 1.54 1998/09/20 17:46:49 florian
* some things regarding ansistrings fixed
Revision 1.53 1998/09/20 09:38:44 florian
* hasharray for defs fixed
* ansistring code generation corrected (init/final, assignement)
Revision 1.52 1998/09/17 09:42:31 peter
+ pass_2 for cg386
* Message() -> CGMessage() for pass_1/pass_2
Revision 1.51 1998/09/14 10:44:05 peter
* all internal RTL functions start with FPC_
Revision 1.50 1998/09/07 18:46:01 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.49 1998/09/05 22:10:52 florian
+ switch -vb
* while/repeat loops accept now also word/longbool conditions
* makebooltojump did an invalid ungetregister32, fixed
Revision 1.48 1998/09/04 08:41:52 peter
* updated some error CGMessages
Revision 1.47 1998/09/03 17:08:41 pierre
* better lines for stabs
(no scroll back to if before else part
no return to case line at jump outside case)
+ source lines also if not in order
Revision 1.46 1998/09/03 16:03:16 florian
+ rtti generation
* init table generation changed
Revision 1.45 1998/09/01 12:48:03 peter
* use pdef^.size instead of orddef^.typ
Revision 1.44 1998/09/01 09:07:11 peter
* m68k fixes, splitted cg68k like cgi386
Revision 1.43 1998/08/21 08:40:52 pierre
* EBX,EDI,ESI saved for CDECL on all i386 targets
Revision 1.42 1998/08/19 16:07:41 jonas
* changed optimizer switches + cleanup of DestroyRefs in daopt386.pas
Revision 1.41 1998/08/19 00:40:43 peter
* small crash prevention
Revision 1.40 1998/08/17 10:10:06 peter
- removed OLDPPU
Revision 1.39 1998/08/15 16:51:39 peter
* save also esi,ebx for cdecl procedures
Revision 1.38 1998/08/14 18:18:42 peter
+ dynamic set contruction
* smallsets are now working (always longint size)
Revision 1.37 1998/08/11 00:00:30 peter
* fixed dup log
Revision 1.36 1998/08/10 14:49:52 peter
+ localswitches, moduleswitches, globalswitches splitting
Revision 1.35 1998/08/05 16:00:11 florian
* some fixes for ansi strings
Revision 1.34 1998/07/30 11:18:14 florian
+ first implementation of try ... except on .. do end;
* limitiation of 65535 bytes parameters for cdecl removed
Revision 1.33 1998/07/27 21:57:12 florian
* fix to allow tv like stream registration:
@tmenu.load doesn't work if load had parameters or if load was only
declared in an anchestor class of tmenu
Revision 1.32 1998/07/27 11:23:40 florian
+ procedures with the directive cdecl and with target linux save now
the register EDI (like GCC procedures).
Revision 1.31 1998/07/20 18:40:11 florian
* handling of ansi string constants should now work
Revision 1.30 1998/07/18 22:54:26 florian
* some ansi/wide/longstring support fixed:
o parameter passing
o returning as result from functions
Revision 1.29 1998/07/06 13:21:13 michael
+ Fixed Initialization/Finalizarion calls
Revision 1.28 1998/06/25 08:48:11 florian
* first version of rtti support
Revision 1.27 1998/06/24 14:48:32 peter
* ifdef newppu -> ifndef oldppu
Revision 1.26 1998/06/16 08:56:19 peter
+ targetcpu
* cleaner pmodules for newppu
Revision 1.25 1998/06/08 13:13:40 pierre
+ temporary variables now in temp_gen.pas unit
because it is processor independent
* mppc68k.bat modified to undefine i386 and support_mmx
(which are defaults for i386)
Revision 1.24 1998/06/07 15:30:23 florian
+ first working rtti
+ data init/final. for local variables
Revision 1.23 1998/06/05 17:49:53 peter
* cleanup of cgai386
Revision 1.22 1998/06/04 09:55:34 pierre
* demangled name of procsym reworked to become
independant of the mangling scheme
Revision 1.21 1998/06/03 22:48:51 peter
+ wordbool,longbool
* rename bis,von -> high,low
* moved some systemunit loading/creating to psystem.pas
Revision 1.20 1998/05/30 14:31:03 peter
+ $ASMMODE
Revision 1.19 1998/05/23 01:21:02 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.18 1998/05/20 09:42:32 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.17 1998/05/11 13:07:53 peter
+ $ifdef NEWPPU for the new ppuformat
+ $define GDB not longer required
* removed all warnings and stripped some log comments
* no findfirst/findnext anymore to remove smartlink *.o files
Revision 1.16 1998/05/07 00:17:00 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga
to tree and hcodegen and cleanup of hcodegen
* assembling .. output reduced for smartlinking ;)
Revision 1.15 1998/05/06 08:38:35 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.14 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.13 1998/05/01 16:38:43 florian
* handling of private and protected fixed
+ change_keywords_to_tp implemented to remove
keywords which aren't supported by tp
* break and continue are now symbols of the system unit
+ widestring, longstring and ansistring type released
Revision 1.12 1998/05/01 07:43:52 florian
+ basics for rtti implemented
+ switch $m (generate rtti for published sections)
Revision 1.11 1998/04/29 13:41:17 peter
+ assembler functions are not profiled
Revision 1.10 1998/04/29 10:33:47 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.9 1998/04/21 10:16:46 peter
* patches from strasbourg
* objects is not used anymore in the fpc compiled version
Revision 1.8 1998/04/13 08:42:50 florian
* call by reference and call by value open arrays fixed
Revision 1.7 1998/04/09 23:27:26 peter
* fixed profiling results
Revision 1.6 1998/04/09 14:28:03 jonas
+ basic k6 and 6x86 optimizing support (-O7 and -O8)
Revision 1.5 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 !!
}
Reference in New Issue View Git Blame Copy Permalink