paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-04 04:17:53 +01:00
Code Issues Packages Projects Releases Wiki Activity

* some fixes for the floating point registers

Browse Source 
* more things for the new code generator
This commit is contained in:
florian 1999-08-05 14:58:03 +00:00
parent 46b6598b8c
commit fdc1e9792c
12 changed files with 769 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler/cg386cnv.pas
View File

@ -762,8 +762,8 @@ implementation
exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_IL,r)));
exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI)));
end;
end;
end;
inc(fpuvaroffset);
clear_location(pto^.location);
pto^.location.loc:=LOC_FPU;
end;
@ -804,6 +804,7 @@ implementation
clear_location(pto^.location);
pto^.location.loc:=LOC_REGISTER;
pto^.location.register:=rreg;
inc(fpuvaroffset);
end;
@ -1468,7 +1469,11 @@ implementation
end.
{
$Log$
Revision 1.83 1999-08-04 13:45:19 florian
Revision 1.84 1999-08-05 14:58:03 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.83 1999/08/04 13:45:19 florian
+ floating point register variables !!
* pairegalloc is now generated for register variables

10
compiler/cgai386.pas
View File

@ -1197,10 +1197,12 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
r^.offset:=para_offset-pushedparasize;
end;
exprasmlist^.concat(new(pai386,op_ref(op,opsize,r)));
dec(fpuvaroffset);
end;
LOC_CFPUREGISTER:
begin
exprasmlist^.concat(new(pai386,op_reg(A_FLD,S_NO,p^.location.register)));
exprasmlist^.concat(new(pai386,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
@ -3161,7 +3163,11 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
end.
{
$Log$
Revision 1.25 1999-08-04 13:45:24 florian
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

13
compiler/cobjects.pas
View File

@ -96,6 +96,8 @@ unit cobjects;
first,last : plinkedlist_item;
constructor init;
destructor done;
{ destructors the linkedlist without cleaning the items up }
destructor done_noclear;
{ disposes the items of the list }
procedure clear;
@ -922,10 +924,15 @@ end;
destructor tlinkedlist.done;
begin
clear;
end;
destructor tlinkedlist.done_noclear;
begin
end;
procedure tlinkedlist.clear;
var
@ -2209,7 +2216,11 @@ end;
end.
{
$Log$
Revision 1.38 1999-07-18 10:19:46 florian
Revision 1.39 1999-08-05 14:58:07 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.38 1999/07/18 10:19:46 florian
* made it compilable with Dlephi 4 again
+ fixed problem with large stack allocations on win32

7
compiler/cpubase.pas
View File

@ -716,6 +716,7 @@ const
frame_pointer = R_EBP;
self_pointer = R_ESI;
accumulator = R_EAX;
scratchregister = R_EDI;
cpuflags : set of tcpuflags = [];
@ -1010,7 +1011,11 @@ begin
end.
{
$Log$
Revision 1.2 1999-08-04 13:45:25 florian
Revision 1.3 1999-08-05 14:58:09 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.2 1999/08/04 13:45:25 florian
+ floating point register variables !!
* pairegalloc is now generated for register variables

7
compiler/new/alpha/cpubase.pas
View File

@ -101,6 +101,7 @@ Const
frame_pointer = R_15;
self_pointer = R_16;
accumulator = R_0;
scratchregister = R_14;
{ sizes }
pointersize = 8;
@ -231,7 +232,11 @@ end;
end.
{
$Log$
Revision 1.5 1999-08-03 17:09:48 florian
Revision 1.6 1999-08-05 14:58:17 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.5 1999/08/03 17:09:48 florian
* the alpha compiler can be compiled now
Revision 1.4 1999/08/03 15:52:40 michael

10
compiler/new/cgbase.pas
View File

@ -35,6 +35,10 @@ unit cgbase;
pi_C_import = $10; { set, if the procedure is an external C function }
pi_uses_exceptions = $20;{ set, if the procedure has a try statement => }
{ no register variables }
pi_is_assembler = $40; { set if the procedure is declared as ASSEMBLER
=> don't optimize}
pi_needs_implicit_finally = $80; { set, if the procedure contains data which }
{ needs to be finalized }
type
pprocinfo = ^tprocinfo;
@ -393,7 +397,11 @@ unit cgbase;
end.
{
$Log$
Revision 1.6 1999-08-04 00:23:51 florian
Revision 1.7 1999-08-05 14:58:10 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.6 1999/08/04 00:23:51 florian
* renamed i386asm and i386base to cpuasm and cpubase
Revision 1.5 1999/08/01 18:22:32 florian

91
compiler/new/cgobj.pas
View File

@ -42,14 +42,10 @@ unit cgobj;
{ code generation for subroutine entry/exit code }
{ helper routines }
procedure g_initialize_data(p : psym);
procedure g_incr_data(p : psym);
procedure g_finalize_data(p : pnamedindexobject);
{$ifndef VALUEPARA}
procedure g_copyopenarrays(p : pnamedindexobject);
{$else}
procedure g_copyvalueparas(p : pnamedindexobject);
{$endif}
procedure g_initialize_data(list : paasmoutput;p : psym);
procedure g_incr_data(list : paasmoutput;p : psym);
procedure g_finalize_data(list : paasmoutput;p : pnamedindexobject);
procedure g_copyvalueparas(list : paasmoutput;p : pnamedindexobject);
procedure g_entrycode(list : paasmoutput;
const proc_names : tstringcontainer;make_global : boolean;
@ -75,6 +71,7 @@ unit cgobj;
procedure a_load_const32_ref(list : paasmoutput;l : longint;const ref : treference);virtual;
procedure a_load_const64_ref(list : paasmoutput;q : qword;const ref : treference);virtual;
procedure a_loadaddress_ref_reg(list : paasmoutput;ref : treference;r : tregister);virtual;
procedure g_stackframe_entry(list : paasmoutput;localsize : longint);virtual;
procedure g_maybe_loadself(list : paasmoutput);virtual;
@ -99,6 +96,7 @@ unit cgobj;
procedure a_param_const16(list : paasmoutput;w : word;nr : longint);virtual;
procedure a_param_const32(list : paasmoutput;l : longint;nr : longint);virtual;
procedure a_param_const64(list : paasmoutput;q : qword;nr : longint);virtual;
procedure a_param_ref(list : paasmoutput;r : treference;nr : longint);virtual;
end;
var
@ -170,6 +168,13 @@ unit cgobj;
{!!!!!!!! a_push_const64(list,q); }
end;
procedure tcg.a_param_ref(list : paasmoutput;r : treference;nr : longint);
begin
a_loadaddress_ref_reg(list,r,scratchregister);
a_param_reg(list,scratchregister,nr);
end;
procedure tcg.g_stackcheck(list : paasmoutput;stackframesize : longint);
begin
@ -225,21 +230,40 @@ unit cgobj;
*****************************************************************************}
{ generates the code for initialisation of local data }
procedure tcg.g_initialize_data(p : psym);
procedure tcg.g_initialize_data(list : paasmoutput;p : psym);
begin
runerror(255);
end;
{ generates the code for incrementing the reference count of parameters }
procedure tcg.g_incr_data(p : psym);
procedure tcg.g_incr_data(list : paasmoutput;p : psym);
var
hr : treference;
begin
runerror(255);
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)) then
begin
procinfo.flags:=procinfo.flags or pi_needs_implicit_finally;
reset_reference(hr);
hr.symbol:=pvarsym(p)^.definition^.get_inittable_label;
a_param_ref(list,hr,2);
reset_reference(hr);
hr.base:=procinfo.framepointer;
hr.offset:=pvarsym(p)^.address+procinfo.call_offset;
a_param_ref(list,hr,1);
reset_reference(hr);
a_call_name(list,'FPC_ADDREF',0);
end;
end;
{ generates the code for finalisation of local data }
procedure tcg.g_finalize_data(p : pnamedindexobject);
procedure tcg.g_finalize_data(list : paasmoutput;p : pnamedindexobject);
begin
runerror(255);
@ -247,36 +271,39 @@ unit cgobj;
{ generates the code to make local copies of the value parameters }
procedure tcg.g_copyopenarrays(p : pnamedindexobject);
procedure tcg.g_copyvalueparas(list : paasmoutput;p : pnamedindexobject);
begin
runerror(255);
end;
var
_list : paasmoutput;
{ wrappers for the methods, because TP doesn't know procedures }
{ of objects }
procedure _copyopenarrays(s : pnamedindexobject);{$ifndef FPC}far;{$endif}
procedure _copyvalueparas(s : pnamedindexobject);{$ifndef FPC}far;{$endif}
begin
cg^.g_copyopenarrays(s);
cg^.g_copyvalueparas(_list,s);
end;
procedure _finalize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif}
begin
cg^.g_finalize_data(s);
cg^.g_finalize_data(_list,s);
end;
procedure _incr_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif}
begin
cg^.g_incr_data(psym(s));
cg^.g_incr_data(_list,psym(s));
end;
procedure _initialize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif}
begin
cg^.g_initialize_data(psym(s));
cg^.g_initialize_data(_list,psym(s));
end;
{ generates the entry code for a procedure }
@ -384,8 +411,8 @@ unit cgobj;
begin
if procinfo._class^.isclass then
begin
list^.insert(new(pai386,op_cond_sym(A_Jcc,C_Z,S_NO,quickexitlabel)));
list^.insert(new(pai386,op_sym(A_CALL,S_NO,newasmsymbol('FPC_NEW_CLASS'))));
list^.concat(new(pai386,op_sym(A_CALL,S_NO,newasmsymbol('FPC_NEW_CLASS'))));
list^.concat(new(pai386,op_cond_sym(A_Jcc,C_Z,S_NO,quickexitlabel)));
end
else
begin
@ -414,15 +441,10 @@ unit cgobj;
a_load_const32_ref(list,0,hr);
end;
_list:=list;
{ generate copies of call by value parameters }
if (po_assembler in aktprocsym^.definition^.procoptions) then
begin
{$ifndef VALUEPARA}
aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_copyopenarrays);
{$else}
aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_copyvalueparas);
{$endif}
end;
aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_copyvalueparas);
{ initialisizes local data }
aktprocsym^.definition^.localst^.foreach({$ifdef FPC}@{$endif FPC}_initialize_data);
@ -484,7 +506,6 @@ unit cgobj;
begin
{$ifdef dummy}
{ !!!! insert there automatic destructors }
curlist:=list;
if aktexitlabel^.is_used then
list^.insert(new(pai_label,init(aktexitlabel)));
@ -505,7 +526,7 @@ unit cgobj;
concat_external('FPC_HELP_DESTRUCTOR',EXT_NEAR);
end;
end;
_list:=list;
{ finalize local data }
aktprocsym^.definition^.localst^.foreach({$ifdef FPC}@{$endif FPC}finalize_data);
@ -671,10 +692,20 @@ unit cgobj;
abstract;
end;
procedure tcg.a_loadaddress_ref_reg(list : paasmoutput;ref : treference;r : tregister);
begin
abstract;
end;
end.
{
$Log$
Revision 1.10 1999-08-04 00:23:52 florian
Revision 1.11 1999-08-05 14:58:11 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.10 1999/08/04 00:23:52 florian
* renamed i386asm and i386base to cpuasm and cpubase
Revision 1.9 1999/08/02 23:13:21 florian

490
compiler/new/nmem.pas
View File

@ -35,7 +35,21 @@ unit nmem;
is_absolute,is_first,is_methodpointer : boolean;
constructor init(v : pvarsym;st : psymtable);
destructor done;virtual;
procedure det_temp;virtual;
procedure det_resulttype;virtual;
procedure secondpass;virtual;
end;
tassigntyp = (at_normal,at_plus,at_minus,at_star,at_slash);
passignmentnode = ^tassignmentnode;
tassignmentnode = object(tbinarynode)
assigntyp : tassigntyp;
concat_string : boolean;
constructor init(l,r : pnode);
destructor done;virtual;
procedure det_temp;virtual;
procedure det_resulttype;virtual;
procedure secondpass;virtual;
end;
@ -116,7 +130,7 @@ unit nmem;
end
{$ifdef i386}
{ DLL variable, DLL variables are onyl available on the win32 target }
{ DLL variable, DLL variables are only available on the win32 target }
{ maybe we've to add this later for the alpha WinNT }
else if (pvarsym(symtableentry)^.var_options and vo_is_dll_var)<>0 then
begin
@ -134,9 +148,17 @@ unit nmem;
{ in case it is a register variable: }
if pvarsym(symtableentry)^.reg<>R_NO then
begin
location.loc:=LOC_CREGISTER;
if pvarsym(p^.symtableentry)^.reg in fpureg then
begin
location.loc:=LOC_CFPUREGISTER;
tg.unusedregsfpu:=tg.unusedregsfpu-[pvarsym(symtableentry)^.reg];
end
else
begin
location.loc:=LOC_CREGISTER;
tg.unusedregsint:=tg.unusedregsint-[pvarsym(symtableentry)^.reg];
end;
location.register:=pvarsym(symtableentry)^.reg;
tg.unusedregsint:=tg.unusedregsint-[pvarsym(symtableentry)^.reg];
end
else
begin
@ -268,10 +290,470 @@ unit nmem;
end;
end;
{****************************************************************************
TASSIGNMENTNODE
****************************************************************************}
constructor tassignmentnode.init(l,r : pnode);
begin
inherited init(l,r);
concat_string:=false;
assigntyp:=at_normal;
end;
destructor tassignmentnode.done;
begin
inherited done;
end;
procedure tassignmentnode.det_temp;
begin
store_valid:=must_be_valid;
must_be_valid:=false;
{ must be made unique }
set_unique(p^.left);
firstpass(p^.left);
if codegenerror then
exit;
{ test if we can avoid copying string to temp
as in s:=s+...; (PM) }
must_be_valid:=true;
firstpass(p^.right);
must_be_valid:=store_valid;
if codegenerror then
exit;
{ some string functions don't need conversion, so treat them separatly }
if is_shortstring(p^.left^.resulttype) and (assigned(p^.right^.resulttype)) then
begin
if not (is_shortstring(p^.right^.resulttype) or
is_ansistring(p^.right^.resulttype) or
is_char(p^.right^.resulttype)) then
begin
p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
firstpass(p^.right);
if codegenerror then
exit;
end;
{ we call STRCOPY }
procinfo.flags:=procinfo.flags or pi_do_call;
hp:=p^.right;
end
else
begin
p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
firstpass(p^.right);
if codegenerror then
exit;
end;
{ set assigned flag for varsyms }
if (p^.left^.treetype=loadn) and
(p^.left^.symtableentry^.typ=varsym) and
(pvarsym(p^.left^.symtableentry)^.varstate=vs_declared) then
pvarsym(p^.left^.symtableentry)^.varstate:=vs_assigned;
p^.registersint:=p^.left^.registersint+p^.right^.registersint;
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
p^.registersmm:=max(p^.left^.registersmm,p^.right^.registersmm);
end;
procedure tassignmentnode.det_resulttype;
begin
inherited det_resulttype;
resulttype:=voiddef;
{ assignements to open arrays aren't allowed }
if is_open_array(p^.left^.resulttype) then
CGMessage(type_e_mismatch);
end;
procedure tassignmentnode.secondpass;
begin
{ calculate left sides }
if not(p^.concat_string) then
secondpass(p^.left);
if codegenerror then
exit;
case p^.left^.location.loc of
LOC_REFERENCE : begin
{ in case left operator uses to register }
{ but to few are free then LEA }
if (p^.left^.location.reference.base<>R_NO) and
(p^.left^.location.reference.index<>R_NO) and
(usablereg32<p^.right^.registers32) then
begin
del_reference(p^.left^.location.reference);
hregister:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(
p^.left^.location.reference),
hregister)));
reset_reference(p^.left^.location.reference);
p^.left^.location.reference.base:=hregister;
p^.left^.location.reference.index:=R_NO;
end;
loc:=LOC_REFERENCE;
end;
LOC_CFPUREGISTER:
loc:=LOC_CFPUREGISTER;
LOC_CREGISTER:
loc:=LOC_CREGISTER;
LOC_MMXREGISTER:
loc:=LOC_MMXREGISTER;
LOC_CMMXREGISTER:
loc:=LOC_CMMXREGISTER;
else
begin
CGMessage(cg_e_illegal_expression);
exit;
end;
end;
{ lets try to optimize this (PM) }
{ define a dest_loc that is the location }
{ and a ptree to verify that it is the right }
{ place to insert it }
{$ifdef test_dest_loc}
if (aktexprlevel<4) then
begin
dest_loc_known:=true;
dest_loc:=p^.left^.location;
dest_loc_tree:=p^.right;
end;
{$endif test_dest_loc}
secondpass(p^.right);
if codegenerror then
exit;
{$ifdef test_dest_loc}
dest_loc_known:=false;
if in_dest_loc then
begin
truelabel:=otlabel;
falselabel:=oflabel;
in_dest_loc:=false;
exit;
end;
{$endif test_dest_loc}
if p^.left^.resulttype^.deftype=stringdef then
begin
if is_ansistring(p^.left^.resulttype) then
begin
{ the source and destinations are released
in loadansistring, because an ansi string can
also be in a register
}
loadansistring(p);
end
else
if is_shortstring(p^.left^.resulttype) and
not (p^.concat_string) then
begin
if is_ansistring(p^.right^.resulttype) then
begin
if (p^.right^.treetype=stringconstn) and
(p^.right^.length=0) then
begin
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
0,newreference(p^.left^.location.reference))));
{$IfDef regallocfix}
del_reference(p^.left^.location.reference);
{$EndIf regallocfix}
end
else
loadansi2short(p^.right,p^.left);
end
else
begin
{ we do not need destination anymore }
del_reference(p^.left^.location.reference);
del_reference(p^.right^.location.reference);
loadshortstring(p);
ungetiftemp(p^.right^.location.reference);
end;
end
else if is_longstring(p^.left^.resulttype) then
begin
end
else
begin
{ its the only thing we have to do }
del_reference(p^.right^.location.reference);
end
end
else case p^.right^.location.loc of
LOC_REFERENCE,
LOC_MEM : begin
{ extra handling for ordinal constants }
if (p^.right^.treetype in [ordconstn,fixconstn]) or
(loc=LOC_CREGISTER) then
begin
case p^.left^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
{ S_L is correct, the copy is done }
{ with two moves }
8 : opsize:=S_L;
end;
if loc=LOC_CREGISTER then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
newreference(p^.right^.location.reference),
p^.left^.location.register)));
if is_64bitint(p^.right^.resulttype) then
begin
r:=newreference(p^.right^.location.reference);
inc(r^.offset,4);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,r,
p^.left^.location.registerhigh)));
end;
{$IfDef regallocfix}
del_reference(p^.right^.location.reference);
{$EndIf regallocfix}
end
else
begin
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,opsize,
p^.right^.location.reference.offset,
newreference(p^.left^.location.reference))));
if is_64bitint(p^.right^.resulttype) then
begin
r:=newreference(p^.left^.location.reference);
inc(r^.offset,4);
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,opsize,
0,r)));
end;
{$IfDef regallocfix}
del_reference(p^.left^.location.reference);
{$EndIf regallocfix}
{exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,opsize,
p^.right^.location.reference.offset,
p^.left^.location)));}
end;
end
else if loc=LOC_CFPUREGISTER then
begin
floatloadops(pfloatdef(p^.right^.resulttype)^.typ,op,opsize);
exprasmlist^.concat(new(pai386,op_ref(op,opsize,
newreference(p^.right^.location.reference))));
exprasmlist^.concat(new(pai386,op_reg(A_FSTP,S_NO,
correct_fpuregister(p^.left^.location.register,fpuvaroffset+1))));
end
else
begin
if (p^.right^.resulttype^.needs_inittable) and
( (p^.right^.resulttype^.deftype<>objectdef) or
not(pobjectdef(p^.right^.resulttype)^.is_class)) then
begin
{ this would be a problem }
if not(p^.left^.resulttype^.needs_inittable) then
internalerror(3457);
{ increment source reference counter }
new(r);
reset_reference(r^);
r^.symbol:=p^.right^.resulttype^.get_inittable_label;
emitpushreferenceaddr(r^);
emitpushreferenceaddr(p^.right^.location.reference);
exprasmlist^.concat(new(pai386,
op_sym(A_CALL,S_NO,newasmsymbol('FPC_ADDREF'))));
{ decrement destination reference counter }
new(r);
reset_reference(r^);
r^.symbol:=p^.left^.resulttype^.get_inittable_label;
emitpushreferenceaddr(r^);
emitpushreferenceaddr(p^.left^.location.reference);
exprasmlist^.concat(new(pai386,
op_sym(A_CALL,S_NO,newasmsymbol('FPC_DECREF'))));
end;
{$ifdef regallocfix}
concatcopy(p^.right^.location.reference,
p^.left^.location.reference,p^.left^.resulttype^.size,true,false);
ungetiftemp(p^.right^.location.reference);
{$Else regallocfix}
concatcopy(p^.right^.location.reference,
p^.left^.location.reference,p^.left^.resulttype^.size,false,false);
ungetiftemp(p^.right^.location.reference);
{$endif regallocfix}
end;
end;
{$ifdef SUPPORT_MMX}
LOC_CMMXREGISTER,
LOC_MMXREGISTER:
begin
if loc=LOC_CMMXREGISTER then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO,
p^.right^.location.register,p^.left^.location.register)))
else
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO,
p^.right^.location.register,newreference(p^.left^.location.reference))));
end;
{$endif SUPPORT_MMX}
LOC_REGISTER,
LOC_CREGISTER : begin
case p^.right^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
8 : opsize:=S_L;
end;
{ simplified with op_reg_loc }
if loc=LOC_CREGISTER then
begin
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize,
p^.right^.location.register,
p^.left^.location.register)));
{$IfDef regallocfix}
ungetregister(p^.right^.location.register);
{$EndIf regallocfix}
end
else
Begin
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,
p^.right^.location.register,
newreference(p^.left^.location.reference))));
{$IfDef regallocfix}
ungetregister(p^.right^.location.register);
del_reference(p^.left^.location.reference);
{$EndIf regallocfix}
end;
if is_64bitint(p^.right^.resulttype) then
begin
{ simplified with op_reg_loc }
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize,
p^.right^.location.registerhigh,
p^.left^.location.registerhigh)))
else
begin
r:=newreference(p^.left^.location.reference);
inc(r^.offset,4);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,
p^.right^.location.registerhigh,r)));
end;
end;
{exprasmlist^.concat(new(pai386,op_reg_loc(A_MOV,opsize,
p^.right^.location.register,
p^.left^.location))); }
end;
LOC_FPU : begin
if (p^.left^.resulttype^.deftype=floatdef) then
fputyp:=pfloatdef(p^.left^.resulttype)^.typ
else
if (p^.right^.resulttype^.deftype=floatdef) then
fputyp:=pfloatdef(p^.right^.resulttype)^.typ
else
if (p^.right^.treetype=typeconvn) and
(p^.right^.left^.resulttype^.deftype=floatdef) then
fputyp:=pfloatdef(p^.right^.left^.resulttype)^.typ
else
fputyp:=s32real;
case loc of
LOC_CFPUREGISTER:
begin
exprasmlist^.concat(new(pai386,op_reg(A_FSTP,S_NO,
correct_fpuregister(p^.left^.location.register,fpuvaroffset))));
dec(fpuvaroffset);
end;
LOC_REFERENCE:
floatstore(fputyp,p^.left^.location.reference);
else
internalerror(48991);
end;
end;
LOC_CFPUREGISTER: begin
if (p^.left^.resulttype^.deftype=floatdef) then
fputyp:=pfloatdef(p^.left^.resulttype)^.typ
else
if (p^.right^.resulttype^.deftype=floatdef) then
fputyp:=pfloatdef(p^.right^.resulttype)^.typ
else
if (p^.right^.treetype=typeconvn) and
(p^.right^.left^.resulttype^.deftype=floatdef) then
fputyp:=pfloatdef(p^.right^.left^.resulttype)^.typ
else
fputyp:=s32real;
exprasmlist^.concat(new(pai386,op_reg(A_FLD,S_NO,
correct_fpuregister(p^.right^.location.register,fpuvaroffset))));
inc(fpuvaroffset);
case loc of
LOC_CFPUREGISTER:
begin
exprasmlist^.concat(new(pai386,op_reg(A_FSTP,S_NO,
correct_fpuregister(p^.right^.location.register,fpuvaroffset))));
dec(fpuvaroffset);
end;
LOC_REFERENCE:
floatstore(fputyp,p^.left^.location.reference);
else
internalerror(48992);
end;
end;
LOC_JUMP : begin
getlabel(hlabel);
emitlab(truelabel);
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,
1,p^.left^.location.register)))
else
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
1,newreference(p^.left^.location.reference))));
{exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B,
1,p^.left^.location)));}
emitjmp(C_None,hlabel);
emitlab(falselabel);
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,
p^.left^.location.register,
p^.left^.location.register)))
else
begin
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
0,newreference(p^.left^.location.reference))));
{$IfDef regallocfix}
del_reference(p^.left^.location.reference);
{$EndIf regallocfix}
end;
emitlab(hlabel);
end;
LOC_FLAGS : begin
if loc=LOC_CREGISTER then
emit_flag2reg(p^.right^.location.resflags,p^.left^.location.register)
else
begin
ai:=new(pai386,op_ref(A_Setcc,S_B,newreference(p^.left^.location.reference)));
ai^.SetCondition(flag_2_cond[p^.right^.location.resflags]);
exprasmlist^.concat(ai);
end;
{$IfDef regallocfix}
del_reference(p^.left^.location.reference);
{$EndIf regallocfix}
end;
end;
end;
end.
{
$Log$
Revision 1.5 1999-08-04 00:23:56 florian
Revision 1.6 1999-08-05 14:58:13 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.5 1999/08/04 00:23:56 florian
* renamed i386asm and i386base to cpuasm and cpubase
Revision 1.4 1999/08/03 17:09:45 florian

12
compiler/new/nstatmnt.pas
View File

@ -30,9 +30,9 @@ unit nstatmnt;
type
pblocknode = ^tblocknode;
tblocknode = object(tunarynode)
constructor init(l : pnode);
procedure det_temp;virtual;
procedure det_resulttype;virtual;
constructor init(l : pnode);
procedure det_temp;virtual;
procedure det_resulttype;virtual;
procedure secondpass;virtual;
end;
@ -146,7 +146,11 @@ unit nstatmnt;
end.
{
$Log$
Revision 1.3 1999-08-02 17:14:09 florian
Revision 1.4 1999-08-05 14:58:14 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.3 1999/08/02 17:14:09 florian
+ changed the temp. generator to an object
Revision 1.2 1999/08/01 23:36:43 florian

50
compiler/new/pass_2.pas
View File

@ -132,12 +132,25 @@ implementation
cg^.g_maybe_loadself(exprasmlist);
end;
function generateexprlist(p : pnode) : plinkedlist;
var
l : plinkedlist;
begin
l:=new(plinkedlist,init);
p^.concattolist(l);
generateexprlist:=l;
end;
procedure secondpass(p : pnode);
var
oldcodegenerror : boolean;
oldlocalswitches : tlocalswitches;
oldpos : tfileposinfo;
l : plinkedlist;
hp : pnode;
begin
if not(p^.error) then
@ -149,9 +162,35 @@ implementation
aktfilepos:=p^.fileinfo;
aktlocalswitches:=p^.localswitches;
codegenerror:=false;
p^.secondpass;
p^.error:=codegenerror;
{ do we have a list of statements? }
if p^.treetype=statementn then
begin
l:=generateexprlist(p);
{ here we should do CSE and node reordering }
hp:=pnode(l^.first);
while assigned(hp) do
begin
if assigned(hp^.parent) then
begin
if nf_needs_truefalselabel in hp^.parent^.flags then
begin
if not(assigned(punarynode(hp^.parent)^.truelabel)) then
getlabel(punarynode(hp^.parent)^.truelabel);
if not(assigned(punarynode(hp^.parent)^.falselabel)) then
getlabel(punarynode(hp^.parent)^.falselabel);
truelabel:=punarynode(hp^.parent)^.truelabel;
falselabel:=punarynode(hp^.parent)^.falselabel;
end;
end;
hp^.secondpass;
hp:=pnode(hp^.next);
end;
end
else
p^.secondpass;
p^.error:=codegenerror;
codegenerror:=codegenerror or oldcodegenerror;
aktlocalswitches:=oldlocalswitches;
aktfilepos:=oldpos;
@ -409,6 +448,7 @@ implementation
if assigned(aktprocsym) and
(pocall_inline in aktprocsym^.definition^.proccalloptions) then
make_const_global:=true;
do_secondpass(p);
if assigned(procinfo.def) then
@ -424,7 +464,11 @@ implementation
end.
{
$Log$
Revision 1.5 1999-08-04 00:23:58 florian
Revision 1.6 1999-08-05 14:58:15 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.5 1999/08/04 00:23:58 florian
* renamed i386asm and i386base to cpuasm and cpubase
Revision 1.4 1999/08/03 17:09:46 florian

9
compiler/new/powerpc/cpubase.pas
View File

@ -347,7 +347,7 @@ type
tcpuflags = (cf_registers64);}
const
availabletempregsint = [R_0,R_11..R_30];
availabletempregsint = [R_11..R_30];
availabletempregsfpu = [R_F14..R_F31];
availabletempregsmm = [R_M0..R_M31];
@ -372,6 +372,7 @@ const
frame_pointer = R_31;
self_pointer = R_9;
accumulator = R_3;
scratchregister = R_0;
(* cpuflags : set of tcpuflags = []; *)
@ -463,7 +464,11 @@ end;
end.
{
$Log$
Revision 1.2 1999-08-04 12:59:25 jonas
Revision 1.3 1999-08-05 14:58:18 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.2 1999/08/04 12:59:25 jonas
* all tokes now start with an underscore
* PowerPC compiles!!

119
compiler/new/tree.pas
View File

@ -170,12 +170,20 @@ unit tree;
less,greater : pcaserecord;
end;
tnodeflags = (nf_needs_truefalselabel,tf_callunique);
tnodeflagset = set of tnodeflags;
pnode = ^tnode;
tnode = object
tnode = object(tlinkedlist_item)
treetype : ttreetyp;
{ the location of the result of this node }
location : tlocation;
{ the parent node of this is node }
{ this field is set by concattolist }
parent : pnode;
{ there are some properties about the node stored }
flags : tnodeflagset;
{ the number of registers needed to evalute the node }
registersint,registersfpu : longint; { must be longint !!!! }
{$ifdef SUPPORT_MMX}
@ -204,6 +212,8 @@ unit tree;
{ to write a complete tree }
procedure dowrite;virtual;
{$endif EXTDEBUG}
procedure concattolist(l : plinkedlist);virtual;
function ischild(p : pnode) : boolean;virtual;
end;
{ allows to determine which elementes are to be replaced }
@ -269,21 +279,38 @@ unit tree;
arrayconstructn : (cargs,cargswap: boolean);
end;
{ this node is the anchestor for all classes with at least }
{ one child, you have to use it if you want to use }
{ true- and falselabel }
punarynode = ^tunarynode;
tunarynode = object(tnode)
left : pnode;
truelabel,falselabel : pasmlabel;
{$ifdef extdebug}
procedure dowrite;virtual;
{$endif extdebug}
constructor init(l : pnode);
procedure concattolist(l : plinkedlist);virtual;
function ischild(p : pnode) : boolean;virtual;
procedure det_resulttype;virtual;
procedure det_temp;virtual;
end;
pbinarynode = ^tbinarynode;
tbinarynode = object(tunarynode)
right : pnode;
constructor init(l,r : pnode);
procedure concattolist(l : plinkedlist);virtual;
function ischild(p : pnode) : boolean;virtual;
procedure det_resulttype;virtual;
procedure det_temp;virtual;
end;
pvecnode = ^tvecnode;
tvecnode = object(tbinarynode)
end;
pbinopnode = ^tbinopnode;
tbinopnode = object(tbinarynode)
{ is true, if the right and left operand are swaped }
@ -379,7 +406,7 @@ unit tree;
{ sets the callunique flag, if the node is a vecn, }
{ takes care of type casts etc. }
procedure set_unique(p : ptree);
procedure set_unique(p : pnode);
{ gibt den ordinalen Werten der Node zurueck oder falls sie }
{ keinen ordinalen Wert hat, wird ein Fehler erzeugt }
@ -423,6 +450,7 @@ unit tree;
constructor tnode.init;
begin
inherited init;
treetype:=nothingn;
{ this allows easier error tracing }
location.loc:=LOC_INVALID;
@ -435,6 +463,7 @@ unit tree;
{$ifdef SUPPORT_MMX}
registersmmx:=0;
{$endif SUPPORT_MMX}
flags:=[];
end;
destructor tnode.done;
@ -477,6 +506,18 @@ unit tree;
abstract;
end;
procedure tnode.concattolist(l : plinkedlist);
begin
l^.concat(@self);
end;
function tnode.ischild(p : pnode) : boolean;
begin
ischild:=false;
end;
{$ifdef EXTDEBUG}
procedure tnode.dowrite;
@ -587,7 +628,33 @@ unit tree;
writeln(')');
dec(byte(indention[0]),2);
end;
{$endif}
{$endif}
procedure tunarynode.concattolist(l : plinkedlist);
begin
left^.parent:=@self;
left^.concattolist(l);
inherited concattolist(l);
end;
function tunarynode.ischild(p : pnode) : boolean;
begin
ischild:=p=left;
end;
procedure tunarynode.det_resulttype;
begin
left^.det_resulttype;
end;
procedure tunarynode.det_temp;
begin
left^.det_temp;
end;
{****************************************************************************
TBINARYNODE
@ -600,6 +667,38 @@ unit tree;
right:=r
end;
procedure tbinarynode.concattolist(l : plinkedlist);
begin
{ we could change that depending on the number of }
{ required registers }
left^.parent:=@self;
left^.concattolist(l);
left^.parent:=@self;
left^.concattolist(l);
inherited concattolist(l);
end;
function tbinarynode.ischild(p : pnode) : boolean;
begin
ischild:=(p=right) or (p=right);
end;
procedure tbinarynode.det_resulttype;
begin
left^.det_resulttype;
right^.det_resulttype;
end;
procedure tbinarynode.det_temp;
begin
left^.det_temp;
right^.det_temp;
end;
{****************************************************************************
TBINOPYNODE
****************************************************************************}
@ -1817,16 +1916,16 @@ unit tree;
equal_trees:=false;
end;
procedure set_unique(p : ptree);
procedure set_unique(p : pnode);
begin
if assigned(p) then
begin
case p^.treetype of
vecn:
p^.callunique:=true;
include(p^.flags,tf_callunique);
typeconvn:
set_unique(p^.left);
set_unique(punarynode(p)^.left);
end;
end;
end;
@ -1900,7 +1999,11 @@ unit tree;
end.
{
$Log$
Revision 1.11 1999-08-04 00:23:59 florian
Revision 1.12 1999-08-05 14:58:16 florian
* some fixes for the floating point registers
* more things for the new code generator
Revision 1.11 1999/08/04 00:23:59 florian
* renamed i386asm and i386base to cpuasm and cpubase
Revision 1.10 1999/08/02 17:14:12 florian