paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 08:09:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* removed some more routines from cga

Browse Source 
* moved location_force_reg/mem to ncgutil
  * moved arrayconstructnode secondpass to ncgld
This commit is contained in:
peter 2002-04-19 15:39:34 +00:00
parent 2d4b532578
commit 8d0751ff97
11 changed files with 639 additions and 581 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
compiler/i386/cga.pas
View File

@ -64,9 +64,6 @@ interface
procedure emitcall(const routine:string);
procedure emit_mov_ref_reg64(r : treference;rl,rh : 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_mem_size(const t: treference; size: longint);
{ remove non regvar registers in loc from regs (in the format }
@ -75,7 +72,6 @@ interface
procedure emit_pushw_loc(const t:tlocation);
procedure emit_push_lea_loc(const t:tlocation;freetemp:boolean);
procedure emit_to_mem(var t:tlocation;def:tdef);
procedure copyshortstring(const dref,sref : treference;len : byte;
loadref, del_sref: boolean);
@ -331,20 +327,6 @@ implementation
end;
procedure emit_lea_loc_reg(const t:tlocation;reg:tregister;freetemp:boolean);
begin
case t.loc of
LOC_CREFERENCE,
LOC_REFERENCE : begin
emit_ref_reg(A_LEA,S_L,t.reference,reg);
if freetemp then
tg.ungetiftemp(exprasmlist,t.reference);
end;
else
internalerror(200203211);
end;
end;
procedure remove_non_regvars_from_loc(const t: tlocation; var regs: tregisterset);
begin
case t.loc of
@ -402,25 +384,6 @@ implementation
end;
procedure emit_lea_loc_ref(const t:tlocation;const ref:treference;freetemp:boolean);
begin
case t.loc of
LOC_CREFERENCE,
LOC_REFERENCE : begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_LEA,S_L,t.reference,R_EDI);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,ref));
rg.ungetregisterint(exprasmlist,R_EDI);
end;
else
internalerror(200203212);
end;
location_release(exprasmlist,t);
if freetemp then
location_freetemp(exprasmlist,t);
end;
procedure emit_push_lea_loc(const t:tlocation;freetemp:boolean);
begin
case t.loc of
@ -463,70 +426,6 @@ implementation
end;
procedure emit_to_mem(var t:tlocation;def:tdef);
var
r : treference;
begin
case t.loc of
LOC_FPUREGISTER, LOC_CFPUREGISTER :
begin
tg.gettempofsizereference(exprasmlist,10,r);
cg.a_loadfpu_reg_ref(exprasmlist,
def_cgsize(def),t.register,r);
t.reference := r;
end;
LOC_REGISTER:
begin
if is_64bitint(def) then
begin
tg.gettempofsizereference(exprasmlist,8,r);
emit_reg_ref(A_MOV,S_L,t.registerlow,r);
inc(r.offset,4);
emit_reg_ref(A_MOV,S_L,t.registerhigh,r);
dec(r.offset,4);
t.reference:=r;
end
else
internalerror(1405001);
end;
LOC_CREFERENCE,
LOC_REFERENCE : ;
else
internalerror(200203219);
end;
t.loc:=LOC_CREFERENCE;
end;
procedure emit_mov_ref_reg64(r : treference;rl,rh : tregister);
var
hr : treference;
begin
{ if we load a 64 bit reference, we must be careful because }
{ we could overwrite the registers of the reference by }
{ accident }
rg.getexplicitregisterint(exprasmlist,R_EDI);
if r.base=rl then
begin
emit_reg_reg(A_MOV,S_L,r.base, R_EDI);
r.base:=R_EDI;
end
else if r.index=rl then
begin
emit_reg_reg(A_MOV,S_L,r.index,R_EDI);
r.index:=R_EDI;
end;
emit_ref_reg(A_MOV,S_L,r,rl);
hr:=r;
inc(hr.offset,4);
emit_ref_reg(A_MOV,S_L, hr,rh);
rg.ungetregisterint(exprasmlist,R_EDI);
end;
{*****************************************************************************
Emit String Functions
*****************************************************************************}
@ -2402,7 +2301,12 @@ implementation
end.
{
$Log$
Revision 1.23 2002-04-15 19:44:20 peter
Revision 1.24 2002-04-19 15:39:34 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.23 2002/04/15 19:44:20 peter
* fixed stackcheck that would be called recursively when a stack
error was found
* generic changeregsize(reg,size) for i386 register resizing

13
compiler/i386/cpunode.pas
View File

@ -29,8 +29,8 @@ unit cpunode;
implementation
uses
ncgbas,ncgflw,ncgcnv,ncgmem,ncgcon,
n386ld,n386add,n386cal,n386con,n386flw,n386mat,n386mem,
ncgbas,ncgflw,ncgcnv,ncgld,ncgmem,ncgcon,
n386ld,n386add,n386cal,n386con,n386cnv,n386flw,n386mat,n386mem,
n386set,n386inl,n386opt,
{ this not really a node }
n386obj, rgcpu;
@ -38,7 +38,12 @@ unit cpunode;
end.
{
$Log$
Revision 1.8 2002-03-31 20:26:38 jonas
Revision 1.9 2002-04-19 15:39:35 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.8 2002/03/31 20:26:38 jonas
+ a_loadfpu_* and a_loadmm_* methods in tcg
* register allocation is now handled by a class and is mostly processor
independent (+rgobj.pas and i386/rgcpu.pas)
@ -94,4 +99,4 @@ end.
Revision 1.1 2000/10/14 10:14:47 peter
* moehrendorf oct 2000 rewrite
}
}

142
compiler/i386/n386cnv.pas
View File

@ -27,12 +27,12 @@ unit n386cnv;
interface
uses
node,ncnv,ncgcnv,types;
node,ncgcnv,types;
type
ti386typeconvnode = class(tcgtypeconvnode)
protected
procedure second_int_to_int;override;
{ procedure second_int_to_int;override; }
{ procedure second_string_to_string;override; }
{ procedure second_cstring_to_pchar;override; }
{ procedure second_string_to_chararray;override; }
@ -51,51 +51,28 @@ interface
{ procedure second_pchar_to_string;override; }
{ procedure second_class_to_intf;override; }
{ procedure second_char_to_char;override; }
procedure pass_2;override;
procedure second_call_helper(c : tconverttype);
{$ifdef TESTOBJEXT2}
procedure checkobject;override;
{$endif TESTOBJEXT2}
procedure second_call_helper(c : tconverttype);override;
end;
implementation
uses
verbose,systems,
symconst,symdef,aasm,
cginfo,cgbase,pass_2,
ncon,ncal,
ncon,ncal,ncnv,
cpubase,
cgobj,cga,tgobj,rgobj,rgcpu,n386util;
cgobj,cga,tgobj,rgobj,rgcpu,ncgutil;
{*****************************************************************************
SecondTypeConv
*****************************************************************************}
procedure ti386typeconvnode.second_int_to_int;
var
newsize : tcgsize;
begin
newsize:=def_cgsize(resulttype.def);
{ insert range check if not explicit conversion }
if not(nf_explizit in flags) then
cg.g_rangecheck(exprasmlist,left,resulttype.def);
{ is the result size smaller ? }
if resulttype.def.size<>left.resulttype.def.size then
begin
{ reuse the left location by default }
location_copy(location,left.location);
location_force_reg(location,newsize,false);
end
else
begin
{ no special loading is required, reuse current location }
location_copy(location,left.location);
location.size:=newsize;
end;
end;
procedure ti386typeconvnode.second_int_to_real;
var
@ -297,13 +274,42 @@ implementation
falselabel:=oldfalselabel;
end;
{$ifdef TESTOBJEXT2}
procedure ti386typeconvnode.checkobject;
var
r : preference;
nillabel : plabel;
begin
new(r);
reset_reference(r^);
if p^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
r^.base:=p^.location.register
else
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_mov_loc_reg(p^.location,R_EDI);
r^.base:=R_EDI;
end;
{ NIL must be accepted !! }
emit_reg_reg(A_OR,S_L,r^.base,r^.base);
rg.ungetregisterint(exprasmlist,R_EDI);
getlabel(nillabel);
emitjmp(C_E,nillabel);
{ this is one point where we need vmt_offset (PM) }
r^.offset:= tobjectdef(tpointerdef(p^.resulttype.def).definition).vmt_offset;
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,r,R_EDI);
emit_sym(A_PUSH,S_L,
newasmsymbol(tobjectdef(tpointerdef(p^.resulttype.def).definition).vmt_mangledname));
emit_reg(A_PUSH,S_L,R_EDI);
rg.ungetregister32(exprasmlist,R_EDI);
emitcall('FPC_CHECK_OBJECT_EXT');
emitlab(nillabel);
end;
{$endif TESTOBJEXT2}
{****************************************************************************
TI386TYPECONVNODE
****************************************************************************}
procedure ti386typeconvnode.second_call_helper(c : tconverttype);
const
secondconvert : array[tconverttype] of pointer = (
@second_nothing, {equal}
@ -353,69 +359,17 @@ implementation
tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
end;
procedure ti386typeconvnode.pass_2;
{$ifdef TESTOBJEXT2}
var
r : preference;
nillabel : plabel;
{$endif TESTOBJEXT2}
begin
{ the boolean routines can be called with LOC_JUMP and
call secondpass themselves in the helper }
if not(convtype in [tc_bool_2_int,tc_bool_2_bool,tc_int_2_bool]) then
begin
secondpass(left);
if codegenerror then
exit;
end;
second_call_helper(convtype);
{$ifdef TESTOBJEXT2}
{ Check explicit conversions to objects pointers !! }
if p^.explizit and
(p^.resulttype.def.deftype=pointerdef) and
(tpointerdef(p^.resulttype.def).definition.deftype=objectdef) and not
(tobjectdef(tpointerdef(p^.resulttype.def).definition).isclass) and
((tobjectdef(tpointerdef(p^.resulttype.def).definition).options and oo_hasvmt)<>0) and
(cs_check_range in aktlocalswitches) then
begin
new(r);
reset_reference(r^);
if p^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
r^.base:=p^.location.register
else
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_mov_loc_reg(p^.location,R_EDI);
r^.base:=R_EDI;
end;
{ NIL must be accepted !! }
emit_reg_reg(A_OR,S_L,r^.base,r^.base);
rg.ungetregisterint(exprasmlist,R_EDI);
getlabel(nillabel);
emitjmp(C_E,nillabel);
{ this is one point where we need vmt_offset (PM) }
r^.offset:= tobjectdef(tpointerdef(p^.resulttype.def).definition).vmt_offset;
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,r,R_EDI);
emit_sym(A_PUSH,S_L,
newasmsymbol(tobjectdef(tpointerdef(p^.resulttype.def).definition).vmt_mangledname));
emit_reg(A_PUSH,S_L,R_EDI);
rg.ungetregister32(exprasmlist,R_EDI);
emitcall('FPC_CHECK_OBJECT_EXT');
emitlab(nillabel);
end;
{$endif TESTOBJEXT2}
end;
begin
ctypeconvnode:=ti386typeconvnode;
end.
{
$Log$
Revision 1.34 2002-04-15 19:44:21 peter
Revision 1.35 2002-04-19 15:39:35 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.34 2002/04/15 19:44:21 peter
* fixed stackcheck that would be called recursively when a stack
error was found
* generic changeregsize(reg,size) for i386 register resizing

9
compiler/i386/n386inl.pas
View File

@ -58,8 +58,6 @@ implementation
('S32REAL','S64REAL','S80REAL','S64BIT','F16BIT','F32BIT'); }
addsubop:array[in_inc_x..in_dec_x] of TOpCG=(OP_ADD,OP_SUB);
var
opsize : topsize;
op,
asmop : tasmop;
pushed : tpushedsaved;
{inc/dec}
@ -593,7 +591,12 @@ begin
end.
{
$Log$
Revision 1.36 2002-04-15 19:44:21 peter
Revision 1.37 2002-04-19 15:39:35 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.36 2002/04/15 19:44:21 peter
* fixed stackcheck that would be called recursively when a stack
error was found
* generic changeregsize(reg,size) for i386 register resizing

221
compiler/i386/n386ld.pas
View File

@ -42,9 +42,6 @@ interface
procedure pass_2;override;
end;
ti386arrayconstructornode = class(tarrayconstructornode)
procedure pass_2;override;
end;
implementation
@ -55,7 +52,7 @@ implementation
cginfo,cgbase,pass_2,
nmem,ncon,ncnv,
cpubase,cpuasm,
cga,tgobj,n386cnv,n386util,regvars,cgobj,cg64f32,rgobj,rgcpu;
cga,tgobj,n386util,ncgutil,regvars,cgobj,cg64f32,rgobj,rgcpu;
{*****************************************************************************
SecondLoad
@ -773,223 +770,19 @@ implementation
end;
end;
{*****************************************************************************
SecondArrayConstruct
*****************************************************************************}
const
vtInteger = 0;
vtBoolean = 1;
vtChar = 2;
vtExtended = 3;
vtString = 4;
vtPointer = 5;
vtPChar = 6;
vtObject = 7;
vtClass = 8;
vtWideChar = 9;
vtPWideChar = 10;
vtAnsiString = 11;
vtCurrency = 12;
vtVariant = 13;
vtInterface = 14;
vtWideString = 15;
vtInt64 = 16;
vtQWord = 17;
procedure ti386arrayconstructornode.pass_2;
var
hp : tarrayconstructornode;
href : treference;
lt : tdef;
vaddr : boolean;
vtype : longint;
freetemp,
dovariant : boolean;
elesize : longint;
begin
dovariant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant;
if dovariant then
elesize:=8
else
elesize:=tarraydef(resulttype.def).elesize;
if not(nf_cargs in flags) then
begin
location_reset(location,LOC_REFERENCE,OS_NO);
{ Allocate always a temp, also if no elements are required, to
be sure that location is valid (PFV) }
if tarraydef(resulttype.def).highrange=-1 then
tg.gettempofsizereference(exprasmlist,elesize,location.reference)
else
tg.gettempofsizereference(exprasmlist,(tarraydef(resulttype.def).highrange+1)*elesize,location.reference);
href:=location.reference;
end;
hp:=self;
while assigned(hp) do
begin
if assigned(hp.left) then
begin
freetemp:=true;
secondpass(hp.left);
if codegenerror then
exit;
if dovariant then
begin
{ find the correct vtype value }
vtype:=$ff;
vaddr:=false;
lt:=hp.left.resulttype.def;
case lt.deftype of
enumdef,
orddef :
begin
if is_64bitint(lt) then
begin
case torddef(lt).typ of
s64bit:
vtype:=vtInt64;
u64bit:
vtype:=vtQWord;
end;
freetemp:=false;
vaddr:=true;
end
else if (lt.deftype=enumdef) or
is_integer(lt) then
vtype:=vtInteger
else
if is_boolean(lt) then
vtype:=vtBoolean
else
if (lt.deftype=orddef) and (torddef(lt).typ=uchar) then
vtype:=vtChar;
end;
floatdef :
begin
vtype:=vtExtended;
vaddr:=true;
freetemp:=false;
end;
procvardef,
pointerdef :
begin
if is_pchar(lt) then
vtype:=vtPChar
else
vtype:=vtPointer;
end;
classrefdef :
vtype:=vtClass;
objectdef :
begin
vtype:=vtObject;
end;
stringdef :
begin
if is_shortstring(lt) then
begin
vtype:=vtString;
vaddr:=true;
freetemp:=false;
end
else
if is_ansistring(lt) then
begin
vtype:=vtAnsiString;
freetemp:=false;
end
else
if is_widestring(lt) then
begin
vtype:=vtWideString;
freetemp:=false;
end;
end;
end;
if vtype=$ff then
internalerror(14357);
{ write C style pushes or an pascal array }
if nf_cargs in flags then
begin
if vaddr then
begin
emit_to_mem(hp.left.location,hp.left.resulttype.def);
emit_push_lea_loc(hp.left.location,freetemp);
location_release(exprasmlist,hp.left.location);
end
else
cg.a_param_loc(exprasmlist,hp.left.location,-1);
inc(pushedparasize,4);
end
else
begin
{ write changing field update href to the next element }
inc(href.offset,4);
if vaddr then
begin
emit_to_mem(hp.left.location,hp.left.resulttype.def);
emit_lea_loc_ref(hp.left.location,href,freetemp);
end
else
begin
location_release(exprasmlist,left.location);
cg.a_load_loc_ref(exprasmlist,hp.left.location,href);
end;
{ update href to the vtype field and write it }
dec(href.offset,4);
emit_const_ref(A_MOV,S_L,vtype,href);
{ goto next array element }
inc(href.offset,8);
end;
end
else
{ normal array constructor of the same type }
begin
case elesize of
1,2,4 :
begin
location_release(exprasmlist,left.location);
cg.a_load_loc_ref(exprasmlist,hp.left.location,href);
end;
8 :
begin
if hp.left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin
emit_reg_ref(A_MOV,S_L,hp.left.location.registerlow,href);
{ update href to the high bytes and write it }
inc(href.offset,4);
emit_reg_ref(A_MOV,S_L,hp.left.location.registerhigh,href);
dec(href.offset,4)
end
else
concatcopy(hp.left.location.reference,href,elesize,freetemp,false);
end;
else
begin
{ concatcopy only supports reference }
if not(hp.left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
internalerror(200108012);
concatcopy(hp.left.location.reference,href,elesize,freetemp,false);
end;
end;
inc(href.offset,elesize);
end;
end;
{ load next entry }
hp:=tarrayconstructornode(hp.right);
end;
end;
begin
cloadnode:=ti386loadnode;
cassignmentnode:=ti386assignmentnode;
cfuncretnode:=ti386funcretnode;
carrayconstructornode:=ti386arrayconstructornode;
end.
{
$Log$
Revision 1.35 2002-04-15 19:44:21 peter
Revision 1.36 2002-04-19 15:39:35 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.35 2002/04/15 19:44:21 peter
* fixed stackcheck that would be called recursively when a stack
error was found
* generic changeregsize(reg,size) for i386 register resizing

9
compiler/i386/n386mem.pas
View File

@ -62,7 +62,7 @@ implementation
cginfo,cgbase,pass_2,
pass_1,nld,ncon,nadd,
cpubase,
cgobj,cga,tgobj,n386util,rgobj;
cgobj,cga,tgobj,rgobj,ncgutil,n386util;
{*****************************************************************************
TI386NEWNODE
@ -663,7 +663,12 @@ begin
end.
{
$Log$
Revision 1.25 2002-04-15 19:12:09 carl
Revision 1.26 2002-04-19 15:39:35 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.25 2002/04/15 19:12:09 carl
+ target_info.size_of_pointer -> pointer_size
+ some cleanup of unused types/variables
* move several constants from cpubase to their specific units

11
compiler/i386/n386set.pas
View File

@ -50,7 +50,7 @@ implementation
cginfo,cgbase,pass_2,
ncon,
cpubase,
cga,cgobj,tgobj,n386util,regvars,rgobj;
cga,cgobj,tgobj,ncgutil,n386util,regvars,rgobj;
const
bytes2Sxx:array[1..8] of Topsize=(S_B,S_W,S_NO,S_L,S_NO,S_NO,S_NO,S_Q);
@ -898,7 +898,7 @@ implementation
{ determines the size of the operand }
opsize:=bytes2Sxx[left.resulttype.def.size];
{ copy the case expression to a register }
location_force_reg(left.location,left.location.size,false);
location_force_reg(left.location,def_cgsize(left.resulttype.def),false);
hregister:=left.location.register;
if isjump then
begin
@ -1030,7 +1030,12 @@ begin
end.
{
$Log$
Revision 1.22 2002-04-15 19:44:21 peter
Revision 1.23 2002-04-19 15:39:35 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.22 2002/04/15 19:44:21 peter
* fixed stackcheck that would be called recursively when a stack
error was found
* generic changeregsize(reg,size) for i386 register resizing

159
compiler/i386/n386util.pas
View File

@ -29,8 +29,6 @@ interface
uses
symtype,node,cpubase,cginfo;
procedure location_force_reg(var l:tlocation;size:TCGSize;maybeconst:boolean);
function maybe_push(needed : byte;p : tnode;isint64 : boolean) : boolean;
function maybe_pushfpu(needed : byte;p : tnode) : boolean;
{$ifdef TEMPS_NOT_PUSH}
@ -63,158 +61,12 @@ implementation
gdb,
{$endif GDB}
types,
ncon,nld,
ncgutil,ncon,nld,
pass_1,pass_2,
cgbase,tgobj,
cga,regvars,cgobj,cg64f32,rgobj,rgcpu,cgcpu;
procedure location_force_reg(var l:tlocation;size:TCGSize;maybeconst:boolean);
var
hregister,
hregisterhi : tregister;
hl : tasmlabel;
begin
{ release previous location before demanding a new register }
if (l.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
begin
location_freetemp(exprasmlist,l);
location_release(exprasmlist,l);
end;
{ handle transformations to 64bit separate }
if size in [OS_64,OS_S64] then
begin
if not (l.size in [OS_64,OS_S64]) then
begin
{ load a smaller size to OS_64 }
if l.loc=LOC_REGISTER then
hregister:=Changeregsize(l.registerlow,S_L)
else
hregister:=rg.getregisterint(exprasmlist);
{ load value in low register }
case l.loc of
LOC_FLAGS :
cg.g_flags2reg(exprasmlist,l.resflags,hregister);
LOC_JUMP :
begin
cg.a_label(exprasmlist,truelabel);
cg.a_load_const_reg(exprasmlist,OS_32,1,hregister);
getlabel(hl);
cg.a_jmp_cond(exprasmlist,OC_NONE,hl);
cg.a_label(exprasmlist,falselabel);
cg.a_load_const_reg(exprasmlist,OS_32,0,hregister);
cg.a_label(exprasmlist,hl);
end;
else
cg.a_load_loc_reg(exprasmlist,l,hregister);
end;
{ reset hi part, take care of the signed bit of the current value }
hregisterhi:=rg.getregisterint(exprasmlist);
if (size=OS_S64) and
(l.size in [OS_S8,OS_S16,OS_S32]) then
begin
if l.loc=LOC_CONSTANT then
begin
if (longint(l.value)<0) then
cg.a_load_const_reg(exprasmlist,OS_32,$ffffffff,hregisterhi)
else
cg.a_load_const_reg(exprasmlist,OS_32,0,hregisterhi);
end
else
begin
cg.a_load_reg_reg(exprasmlist,OS_32,hregister,hregisterhi);
cg.a_op_const_reg(exprasmlist,OP_SAR,31,hregisterhi);
end;
end
else
cg.a_load_const_reg(exprasmlist,OS_32,0,hregisterhi);
location_reset(l,LOC_REGISTER,size);
l.registerlow:=hregister;
l.registerhigh:=hregisterhi;
end
else
begin
{ 64bit to 64bit }
if (l.loc=LOC_REGISTER) or
((l.loc=LOC_CREGISTER) and maybeconst) then
begin
hregister:=l.registerlow;
hregisterhi:=l.registerhigh;
end
else
begin
hregister:=rg.getregisterint(exprasmlist);
hregisterhi:=rg.getregisterint(exprasmlist);
end;
{ load value in new register }
tcg64f32(cg).a_load64_loc_reg(exprasmlist,l,hregister,hregisterhi);
location_reset(l,LOC_REGISTER,size);
l.registerlow:=hregister;
l.registerhigh:=hregisterhi;
end;
end
else
begin
{ transformations to 32bit or smaller }
if l.loc=LOC_REGISTER then
begin
{ if the previous was 64bit release the high register }
if l.size in [OS_64,OS_S64] then
begin
rg.ungetregisterint(exprasmlist,l.registerhigh);
l.registerhigh:=R_NO;
end;
hregister:=l.register;
end
else
begin
{ get new register }
if (l.loc=LOC_CREGISTER) and
maybeconst and
(TCGSize2Size[size]=TCGSize2Size[l.size]) then
hregister:=l.register
else
hregister:=rg.getregisterint(exprasmlist);
end;
{$ifdef i386}
hregister:=Changeregsize(hregister,TCGSize2Opsize[size]);
{$endif i386}
{ load value in new register }
case l.loc of
LOC_FLAGS :
cg.g_flags2reg(exprasmlist,l.resflags,hregister);
LOC_JUMP :
begin
cg.a_label(exprasmlist,truelabel);
cg.a_load_const_reg(exprasmlist,size,1,hregister);
getlabel(hl);
cg.a_jmp_cond(exprasmlist,OC_NONE,hl);
cg.a_label(exprasmlist,falselabel);
cg.a_load_const_reg(exprasmlist,size,0,hregister);
cg.a_label(exprasmlist,hl);
end;
else
begin
{ load_loc_reg can only handle size >= l.size, when the
new size is smaller then we need to adjust the size
of the orignal and maybe recalculate l.register for i386 }
if (TCGSize2Size[size]<TCGSize2Size[l.size]) then
begin
{$ifdef i386}
if (l.loc in [LOC_REGISTER,LOC_CREGISTER]) then
l.register:=Changeregsize(l.register,TCGSize2Opsize[size]);
{$endif i386}
l.size:=size;
end;
cg.a_load_loc_reg(exprasmlist,l,hregister);
end;
end;
location_reset(l,LOC_REGISTER,size);
l.register:=hregister;
end;
end;
{*****************************************************************************
Emit Push Functions
*****************************************************************************}
@ -296,7 +148,7 @@ implementation
begin
if p.location.loc = LOC_FPUREGISTER then
begin
emit_to_mem(p.location,p.resulttype.def);
location_force_mem(p.location);
maybe_pushfpu:=true;
end
else
@ -1260,7 +1112,12 @@ implementation
end.
{
$Log$
Revision 1.31 2002-04-15 19:44:21 peter
Revision 1.32 2002-04-19 15:39:35 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.31 2002/04/15 19:44:21 peter
* fixed stackcheck that would be called recursively when a stack
error was found
* generic changeregsize(reg,size) for i386 register resizing

78
compiler/ncgcnv.pas
View File

@ -28,10 +28,11 @@ unit ncgcnv;
interface
uses
node,ncnv;
node,ncnv,types;
type
tcgtypeconvnode = class(ttypeconvnode)
procedure second_int_to_int;override;
procedure second_cstring_to_pchar;override;
procedure second_string_to_chararray;override;
procedure second_array_to_pointer;override;
@ -46,6 +47,11 @@ interface
procedure second_class_to_intf;override;
procedure second_char_to_char;override;
procedure second_nothing;override;
{$ifdef TESTOBJEXT2}
procedure checkobject;virtual;
{$endif TESTOBJEXT2}
procedure second_call_helper(c : tconverttype);virtual;abstract;
procedure pass_2;override;
end;
implementation
@ -58,13 +64,37 @@ interface
pass_2,
cginfo,cgbase,
cga,cgobj,cgcpu,
{$ifdef i386}
n386util,
{$endif i386}
ncgutil,
tgobj,rgobj
;
procedure tcgtypeconvnode.second_int_to_int;
var
newsize : tcgsize;
begin
newsize:=def_cgsize(resulttype.def);
{ insert range check if not explicit conversion }
if not(nf_explizit in flags) then
cg.g_rangecheck(exprasmlist,left,resulttype.def);
{ is the result size smaller ? }
if resulttype.def.size<>left.resulttype.def.size then
begin
{ reuse the left location by default }
location_copy(location,left.location);
location_force_reg(location,newsize,false);
end
else
begin
{ no special loading is required, reuse current location }
location_copy(location,left.location);
location.size:=newsize;
end;
end;
procedure tcgtypeconvnode.second_cstring_to_pchar;
var
@ -365,13 +395,51 @@ interface
end;
{$ifdef TESTOBJEXT2}
procedure tcgtypeconvnode.checkobject;
begin
{ no checking by default }
end;
{$endif TESTOBJEXT2}
procedure tcgtypeconvnode.pass_2;
begin
{ the boolean routines can be called with LOC_JUMP and
call secondpass themselves in the helper }
if not(convtype in [tc_bool_2_int,tc_bool_2_bool,tc_int_2_bool]) then
begin
secondpass(left);
if codegenerror then
exit;
end;
second_call_helper(convtype);
{$ifdef TESTOBJEXT2}
{ Check explicit conversions to objects pointers !! }
if p^.explizit and
(p^.resulttype.def.deftype=pointerdef) and
(tpointerdef(p^.resulttype.def).definition.deftype=objectdef) and not
(tobjectdef(tpointerdef(p^.resulttype.def).definition).isclass) and
((tobjectdef(tpointerdef(p^.resulttype.def).definition).options and oo_hasvmt)<>0) and
(cs_check_range in aktlocalswitches) then
checkobject;
{$endif TESTOBJEXT2}
end;
begin
ctypeconvnode := tcgtypeconvnode;
end.
{
$Log$
Revision 1.9 2002-04-15 19:44:19 peter
Revision 1.10 2002-04-19 15:39:34 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.9 2002/04/15 19:44:19 peter
* fixed stackcheck that would be called recursively when a stack
error was found
* generic changeregsize(reg,size) for i386 register resizing

268
compiler/ncgld.pas Normal file
View File

@ -0,0 +1,268 @@
{
$Id$
Copyright (c) 1998-2000 by Florian Klaempfl
Generate assembler for nodes that handle loads and assignments which
are the same for all (most) processors
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 ncgld;
{$i defines.inc}
interface
uses
node,nld;
type
tcgarrayconstructornode = class(tarrayconstructornode)
procedure pass_2;override;
end;
implementation
uses
systems,
verbose,globals,
symconst,symtype,symdef,symsym,symtable,aasm,types,
cginfo,cgbase,pass_2,
cpubase,cpuasm,
cga,tgobj,ncgutil,regvars,cgobj,cg64f32,rgobj,rgcpu;
{*****************************************************************************
SecondArrayConstruct
*****************************************************************************}
const
vtInteger = 0;
vtBoolean = 1;
vtChar = 2;
vtExtended = 3;
vtString = 4;
vtPointer = 5;
vtPChar = 6;
vtObject = 7;
vtClass = 8;
vtWideChar = 9;
vtPWideChar = 10;
vtAnsiString = 11;
vtCurrency = 12;
vtVariant = 13;
vtInterface = 14;
vtWideString = 15;
vtInt64 = 16;
vtQWord = 17;
procedure tcgarrayconstructornode.pass_2;
var
hp : tarrayconstructornode;
href : treference;
lt : tdef;
vaddr : boolean;
vtype : longint;
freetemp,
dovariant : boolean;
elesize : longint;
tmpreg : tregister;
begin
dovariant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant;
if dovariant then
elesize:=8
else
elesize:=tarraydef(resulttype.def).elesize;
if not(nf_cargs in flags) then
begin
location_reset(location,LOC_REFERENCE,OS_NO);
{ Allocate always a temp, also if no elements are required, to
be sure that location is valid (PFV) }
if tarraydef(resulttype.def).highrange=-1 then
tg.gettempofsizereference(exprasmlist,elesize,location.reference)
else
tg.gettempofsizereference(exprasmlist,(tarraydef(resulttype.def).highrange+1)*elesize,location.reference);
href:=location.reference;
end;
hp:=self;
while assigned(hp) do
begin
if assigned(hp.left) then
begin
freetemp:=true;
secondpass(hp.left);
if codegenerror then
exit;
if dovariant then
begin
{ find the correct vtype value }
vtype:=$ff;
vaddr:=false;
lt:=hp.left.resulttype.def;
case lt.deftype of
enumdef,
orddef :
begin
if is_64bitint(lt) then
begin
case torddef(lt).typ of
s64bit:
vtype:=vtInt64;
u64bit:
vtype:=vtQWord;
end;
freetemp:=false;
vaddr:=true;
end
else if (lt.deftype=enumdef) or
is_integer(lt) then
vtype:=vtInteger
else
if is_boolean(lt) then
vtype:=vtBoolean
else
if (lt.deftype=orddef) and (torddef(lt).typ=uchar) then
vtype:=vtChar;
end;
floatdef :
begin
vtype:=vtExtended;
vaddr:=true;
freetemp:=false;
end;
procvardef,
pointerdef :
begin
if is_pchar(lt) then
vtype:=vtPChar
else
vtype:=vtPointer;
end;
classrefdef :
vtype:=vtClass;
objectdef :
begin
vtype:=vtObject;
end;
stringdef :
begin
if is_shortstring(lt) then
begin
vtype:=vtString;
vaddr:=true;
freetemp:=false;
end
else
if is_ansistring(lt) then
begin
vtype:=vtAnsiString;
freetemp:=false;
end
else
if is_widestring(lt) then
begin
vtype:=vtWideString;
freetemp:=false;
end;
end;
end;
if vtype=$ff then
internalerror(14357);
{ write C style pushes or an pascal array }
if nf_cargs in flags then
begin
if vaddr then
begin
location_force_mem(hp.left.location);
cg.a_paramaddr_ref(exprasmlist,hp.left.location.reference,-1);
location_release(exprasmlist,hp.left.location);
if freetemp then
location_freetemp(exprasmlist,hp.left.location);
end
else
cg.a_param_loc(exprasmlist,hp.left.location,-1);
inc(pushedparasize,4);
end
else
begin
{ write changing field update href to the next element }
inc(href.offset,4);
if vaddr then
begin
location_force_mem(hp.left.location);
tmpreg:=cg.get_scratch_reg(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,hp.left.location.reference,tmpreg);
cg.a_load_reg_ref(exprasmlist,cg.reg_cgsize(tmpreg),tmpreg,href);
cg.free_scratch_reg(exprasmlist,tmpreg);
location_release(exprasmlist,hp.left.location);
if freetemp then
location_freetemp(exprasmlist,hp.left.location);
end
else
begin
location_release(exprasmlist,left.location);
cg.a_load_loc_ref(exprasmlist,hp.left.location,href);
end;
{ update href to the vtype field and write it }
dec(href.offset,4);
emit_const_ref(A_MOV,S_L,vtype,href);
{ goto next array element }
inc(href.offset,8);
end;
end
else
{ normal array constructor of the same type }
begin
case elesize of
1,2,4 :
begin
location_release(exprasmlist,left.location);
cg.a_load_loc_ref(exprasmlist,hp.left.location,href);
end;
8 :
begin
if hp.left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
tcg64f32(cg).a_load64_loc_ref(exprasmlist,hp.left.location,href)
else
cg.g_concatcopy(exprasmlist,hp.left.location.reference,href,elesize,freetemp,false);
end;
else
begin
{ concatcopy only supports reference }
if not(hp.left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
internalerror(200108012);
cg.g_concatcopy(exprasmlist,hp.left.location.reference,href,elesize,freetemp,false);
end;
end;
inc(href.offset,elesize);
end;
end;
{ load next entry }
hp:=tarrayconstructornode(hp.right);
end;
end;
begin
carrayconstructornode:=tcgarrayconstructornode;
end.
{
$Log$
Revision 1.1 2002-04-19 15:39:34 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
}

202
compiler/ncgutil.pas
View File

@ -27,11 +27,16 @@ unit ncgutil;
interface
uses
node;
node,
cginfo,
cpubase;
type
tloadregvars = (lr_dont_load_regvars, lr_load_regvars);
procedure location_force_reg(var l:tlocation;size:TCGSize;maybeconst:boolean);
procedure location_force_mem(var l:tlocation);
{$ifdef TEMPS_NOT_PUSH}
function maybe_savetotemp(needed : byte;p : tnode;isint64 : boolean) : boolean;
procedure restorefromtemp(p : tnode;isint64 : boolean);
@ -46,9 +51,195 @@ implementation
types,
aasm,cgbase,regvars,
ncon,
cpubase,tgobj,cpuinfo,cginfo,cgobj,cgcpu,rgobj,cg64f32;
tgobj,cpuinfo,cgobj,cgcpu,rgobj,cg64f32;
{*****************************************************************************
TLocation
*****************************************************************************}
procedure location_force_reg(var l:tlocation;size:TCGSize;maybeconst:boolean);
var
hregister,
hregisterhi : tregister;
hl : tasmlabel;
begin
{ release previous location before demanding a new register }
if (l.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
begin
location_freetemp(exprasmlist,l);
location_release(exprasmlist,l);
end;
{ handle transformations to 64bit separate }
if size in [OS_64,OS_S64] then
begin
if not (l.size in [OS_64,OS_S64]) then
begin
{ load a smaller size to OS_64 }
if l.loc=LOC_REGISTER then
hregister:=Changeregsize(l.registerlow,S_L)
else
hregister:=rg.getregisterint(exprasmlist);
{ load value in low register }
case l.loc of
LOC_FLAGS :
cg.g_flags2reg(exprasmlist,l.resflags,hregister);
LOC_JUMP :
begin
cg.a_label(exprasmlist,truelabel);
cg.a_load_const_reg(exprasmlist,OS_32,1,hregister);
getlabel(hl);
cg.a_jmp_cond(exprasmlist,OC_NONE,hl);
cg.a_label(exprasmlist,falselabel);
cg.a_load_const_reg(exprasmlist,OS_32,0,hregister);
cg.a_label(exprasmlist,hl);
end;
else
cg.a_load_loc_reg(exprasmlist,l,hregister);
end;
{ reset hi part, take care of the signed bit of the current value }
hregisterhi:=rg.getregisterint(exprasmlist);
if (size=OS_S64) and
(l.size in [OS_S8,OS_S16,OS_S32]) then
begin
if l.loc=LOC_CONSTANT then
begin
if (longint(l.value)<0) then
cg.a_load_const_reg(exprasmlist,OS_32,$ffffffff,hregisterhi)
else
cg.a_load_const_reg(exprasmlist,OS_32,0,hregisterhi);
end
else
begin
cg.a_load_reg_reg(exprasmlist,OS_32,hregister,hregisterhi);
cg.a_op_const_reg(exprasmlist,OP_SAR,31,hregisterhi);
end;
end
else
cg.a_load_const_reg(exprasmlist,OS_32,0,hregisterhi);
location_reset(l,LOC_REGISTER,size);
l.registerlow:=hregister;
l.registerhigh:=hregisterhi;
end
else
begin
{ 64bit to 64bit }
if (l.loc=LOC_REGISTER) or
((l.loc=LOC_CREGISTER) and maybeconst) then
begin
hregister:=l.registerlow;
hregisterhi:=l.registerhigh;
end
else
begin
hregister:=rg.getregisterint(exprasmlist);
hregisterhi:=rg.getregisterint(exprasmlist);
end;
{ load value in new register }
tcg64f32(cg).a_load64_loc_reg(exprasmlist,l,hregister,hregisterhi);
location_reset(l,LOC_REGISTER,size);
l.registerlow:=hregister;
l.registerhigh:=hregisterhi;
end;
end
else
begin
{ transformations to 32bit or smaller }
if l.loc=LOC_REGISTER then
begin
{ if the previous was 64bit release the high register }
if l.size in [OS_64,OS_S64] then
begin
rg.ungetregisterint(exprasmlist,l.registerhigh);
l.registerhigh:=R_NO;
end;
hregister:=l.register;
end
else
begin
{ get new register }
if (l.loc=LOC_CREGISTER) and
maybeconst and
(TCGSize2Size[size]=TCGSize2Size[l.size]) then
hregister:=l.register
else
hregister:=rg.getregisterint(exprasmlist);
end;
{$ifdef i386}
hregister:=Changeregsize(hregister,TCGSize2Opsize[size]);
{$endif i386}
{ load value in new register }
case l.loc of
LOC_FLAGS :
cg.g_flags2reg(exprasmlist,l.resflags,hregister);
LOC_JUMP :
begin
cg.a_label(exprasmlist,truelabel);
cg.a_load_const_reg(exprasmlist,size,1,hregister);
getlabel(hl);
cg.a_jmp_cond(exprasmlist,OC_NONE,hl);
cg.a_label(exprasmlist,falselabel);
cg.a_load_const_reg(exprasmlist,size,0,hregister);
cg.a_label(exprasmlist,hl);
end;
else
begin
{ load_loc_reg can only handle size >= l.size, when the
new size is smaller then we need to adjust the size
of the orignal and maybe recalculate l.register for i386 }
if (TCGSize2Size[size]<TCGSize2Size[l.size]) then
begin
{$ifdef i386}
if (l.loc in [LOC_REGISTER,LOC_CREGISTER]) then
l.register:=Changeregsize(l.register,TCGSize2Opsize[size]);
{$endif i386}
l.size:=size;
end;
cg.a_load_loc_reg(exprasmlist,l,hregister);
end;
end;
location_reset(l,LOC_REGISTER,size);
l.register:=hregister;
end;
end;
procedure location_force_mem(var l:tlocation);
var
r : treference;
begin
case l.loc of
LOC_FPUREGISTER,
LOC_CFPUREGISTER :
begin
cg.a_loadfpu_reg_ref(exprasmlist,l.size,l.register,r);
location_reset(l,LOC_REFERENCE,l.size);
l.reference:=r;
end;
LOC_CONSTANT,
LOC_REGISTER,
LOC_CREGISTER :
begin
tg.gettempofsizereference(exprasmlist,TCGSize2Size[l.size],r);
if l.size in [OS_64,OS_S64] then
tcg64f32(cg).a_load64_loc_ref(exprasmlist,l,r)
else
cg.a_load_loc_ref(exprasmlist,l,r);
location_reset(l,LOC_REFERENCE,l.size);
l.reference:=r;
end;
LOC_CREFERENCE,
LOC_REFERENCE : ;
else
internalerror(200203219);
end;
end;
{*****************************************************************************
SaveToTemp
*****************************************************************************}
{$ifdef TEMPS_NOT_PUSH}
function maybe_savetotemp(needed : byte;p : tnode;isint64 : boolean) : boolean;
var
@ -213,7 +404,12 @@ end.
{
$Log$
Revision 1.7 2002-04-15 18:58:47 carl
Revision 1.8 2002-04-19 15:39:34 peter
* removed some more routines from cga
* moved location_force_reg/mem to ncgutil
* moved arrayconstructnode secondpass to ncgld
Revision 1.7 2002/04/15 18:58:47 carl
+ target_info.size_of_pointer -> pointer_Size
Revision 1.6 2002/04/06 18:10:42 jonas