paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 14:19:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

* block nodes within expressions shouldn't release the used registers,

Browse Source 
fixed using a flag till the new rg is ready
This commit is contained in:
florian 2002-04-25 20:15:39 +00:00
parent 0cdf327866
commit 6bbaa14daf
9 changed files with 4432 additions and 2904 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

510
compiler/nbas.pas
View File

@ -1,6 +1,6 @@
{
$Id$
Copyright (c) 2000 by Florian Klaempfl
Copyright (c) 2000-2002 by Florian Klaempfl
This unit implements some basic nodes
@ -22,12 +22,15 @@
}
unit nbas;
{$i defines.inc}
{$i fpcdefs.inc}
interface
uses
aasm,symtype,node,cpubase;
cpubase,
aasmbase,aasmtai,aasmcpu,
node,
symtype,symppu;
type
tnothingnode = class(tnode)
@ -41,6 +44,7 @@ interface
constructor create;virtual;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
procedure mark_write;override;
end;
terrornodeclass = class of terrornode;
@ -48,6 +52,9 @@ interface
p_asm : taasmoutput;
constructor create(p : taasmoutput);virtual;
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function getcopy : tnode;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
@ -60,15 +67,18 @@ interface
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
{$ifdef extdebug}
procedure dowrite;override;
procedure _dowrite;override;
{$endif extdebug}
end;
tstatementnodeclass = class of tstatementnode;
tblocknode = class(tunarynode)
constructor create(l : tnode);virtual;
constructor create(l : tnode;releasetemp : boolean);virtual;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
{$ifdef state_tracking}
function track_state_pass(exec_known:boolean):boolean;override;
{$endif state_tracking}
end;
tblocknodeclass = class of tblocknode;
@ -79,10 +89,11 @@ interface
ttempinfo = record
{ set to the copy of a tempcreate pnode (if it gets copied) so that the }
{ refs and deletenode can hook to this copy once they get copied too }
hookoncopy : ptempinfo;
ref : treference;
restype : ttype;
valid : boolean;
hookoncopy : ptempinfo;
ref : treference;
restype : ttype;
valid : boolean;
nextref_set_hookoncopy_nil : boolean;
end;
{ a node which will create a (non)persistent temp of a given type with a given }
@ -113,6 +124,7 @@ interface
function getcopy: tnode; override;
function pass_1 : tnode; override;
function det_resulttype : tnode; override;
procedure mark_write;override;
function docompare(p: tnode): boolean; override;
protected
tempinfo: ptempinfo;
@ -149,7 +161,7 @@ interface
{ Create a blocknode and statement node for multiple statements
generated internally by the parser }
function internalstatements(var laststatement:tstatementnode):tblocknode;
function internalstatements(var laststatement:tstatementnode;releasetemp : boolean):tblocknode;
procedure addstatement(var laststatement:tstatementnode;n:tnode);
@ -158,9 +170,9 @@ implementation
uses
cutils,
verbose,globals,globtype,systems,
symconst,symdef,symsym,types,
symconst,symdef,symsym,defutil,defcmp,
pass_1,
ncal,nflw,rgobj,cgbase
nld,ncal,nflw,rgobj,cginfo,cgbase
;
@ -168,20 +180,20 @@ implementation
Helpers
*****************************************************************************}
function internalstatements(var laststatement:tstatementnode):tblocknode;
function internalstatements(var laststatement:tstatementnode;releasetemp : boolean):tblocknode;
begin
{ create dummy initial statement }
laststatement := cstatementnode.create(nil,cnothingnode.create);
internalstatements := cblocknode.create(laststatement);
laststatement := cstatementnode.create(cnothingnode.create,nil);
internalstatements := cblocknode.create(laststatement,releasetemp);
end;
procedure addstatement(var laststatement:tstatementnode;n:tnode);
begin
if assigned(laststatement.left) then
if assigned(laststatement.right) then
internalerror(200204201);
laststatement.left:=cstatementnode.create(nil,n);
laststatement:=tstatementnode(laststatement.left);
laststatement.right:=cstatementnode.create(n,nil);
laststatement:=tstatementnode(laststatement.right);
end;
@ -191,18 +203,21 @@ implementation
constructor tnothingnode.create;
begin
inherited create(nothingn);
inherited create(nothingn);
end;
function tnothingnode.det_resulttype:tnode;
begin
result:=nil;
resulttype:=voidtype;
result:=nil;
resulttype:=voidtype;
end;
function tnothingnode.pass_1 : tnode;
begin
result:=nil;
result:=nil;
expectloc:=LOC_VOID;
end;
@ -216,6 +231,7 @@ implementation
inherited create(errorn);
end;
function terrornode.det_resulttype:tnode;
begin
result:=nil;
@ -224,12 +240,19 @@ implementation
resulttype:=generrortype;
end;
function terrornode.pass_1 : tnode;
begin
result:=nil;
expectloc:=LOC_VOID;
codegenerror:=true;
end;
procedure terrornode.mark_write;
begin
end;
{*****************************************************************************
TSTATEMENTNODE
*****************************************************************************}
@ -245,54 +268,54 @@ implementation
result:=nil;
resulttype:=voidtype;
{ right is the statement itself calln assignn or a complex one }
resulttypepass(right);
{ left is the statement itself calln assignn or a complex one }
resulttypepass(left);
if (not (cs_extsyntax in aktmoduleswitches)) and
assigned(right.resulttype.def) and
not((right.nodetype=calln) and
(tcallnode(right).procdefinition.proctypeoption=potype_constructor)) and
not(is_void(right.resulttype.def)) then
assigned(left.resulttype.def) and
not((left.nodetype=calln) and
{ don't complain when funcretrefnode is set, because then the
value is already used. And also not for constructors }
(assigned(tcallnode(left).funcretrefnode) or
(tcallnode(left).procdefinition.proctypeoption=potype_constructor))) and
not(is_void(left.resulttype.def)) then
CGMessage(cg_e_illegal_expression);
if codegenerror then
exit;
{ left is the next in the list }
resulttypepass(left);
{ right is the next statement in the list }
if assigned(right) then
resulttypepass(right);
if codegenerror then
exit;
end;
function tstatementnode.pass_1 : tnode;
begin
result:=nil;
{ no temps over several statements }
{$ifndef newra}
rg.cleartempgen;
{ right is the statement itself calln assignn or a complex one }
firstpass(right);
if codegenerror then
exit;
location.loc:=right.location.loc;
registers32:=right.registers32;
registersfpu:=right.registersfpu;
{$ifdef SUPPORT_MMX}
registersmmx:=right.registersmmx;
{$endif SUPPORT_MMX}
{ left is the next in the list }
{$endif}
{ left is the statement itself calln assignn or a complex one }
firstpass(left);
if codegenerror then
exit;
if right.registers32>registers32 then
registers32:=right.registers32;
if right.registersfpu>registersfpu then
registersfpu:=right.registersfpu;
expectloc:=left.expectloc;
registers32:=left.registers32;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
if right.registersmmx>registersmmx then
registersmmx:=right.registersmmx;
{$endif}
registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
{ right is the next in the list }
if assigned(right) then
firstpass(right);
if codegenerror then
exit;
end;
{$ifdef extdebug}
procedure tstatementnode.dowrite;
procedure tstatementnode._dowrite;
begin
{ can't use inherited dowrite, because that will use the
@ -301,11 +324,11 @@ implementation
writeln(',');
{ write the statement }
writenodeindention:=writenodeindention+' ';
writenode(right);
writenode(left);
writeln(')');
delete(writenodeindention,1,4);
{ go on with the next statement }
writenode(left);
writenode(right);
end;
{$endif}
@ -313,10 +336,12 @@ implementation
TBLOCKNODE
*****************************************************************************}
constructor tblocknode.create(l : tnode);
constructor tblocknode.create(l : tnode;releasetemp : boolean);
begin
inherited create(blockn,l);
if releasetemp then
include(flags,nf_releasetemps);
end;
function tblocknode.det_resulttype:tnode;
@ -329,32 +354,37 @@ implementation
hp:=tstatementnode(left);
while assigned(hp) do
begin
if assigned(hp.right) then
if assigned(hp.left) then
begin
codegenerror:=false;
resulttypepass(hp.right);
resulttypepass(hp.left);
if (not (cs_extsyntax in aktmoduleswitches)) and
assigned(hp.right.resulttype.def) and
not((hp.right.nodetype=calln) and
(tcallnode(hp.right).procdefinition.proctypeoption=potype_constructor)) and
not(is_void(hp.right.resulttype.def)) then
CGMessage(cg_e_illegal_expression);
assigned(hp.left.resulttype.def) and
not((hp.left.nodetype=calln) and
{ don't complain when funcretrefnode is set, because then the
value is already used. And also not for constructors }
(assigned(tcallnode(hp.left).funcretrefnode) or
(tcallnode(hp.left).procdefinition.proctypeoption=potype_constructor))) and
not(is_void(hp.left.resulttype.def)) then
CGMessagePos(hp.left.fileinfo,cg_e_illegal_expression);
{ the resulttype of the block is the last type that is
returned. Normally this is a voidtype. But when the
compiler inserts a block of multiple statements then the
last entry can return a value }
resulttype:=hp.right.resulttype;
resulttype:=hp.left.resulttype;
end;
hp:=tstatementnode(hp.left);
hp:=tstatementnode(hp.right);
end;
end;
function tblocknode.pass_1 : tnode;
var
hp : tstatementnode;
count : longint;
begin
result:=nil;
expectloc:=LOC_VOID;
count:=0;
hp:=tstatementnode(left);
while assigned(hp) do
@ -369,51 +399,54 @@ implementation
if {ret_in_acc(aktprocdef.rettype.def) and }
(is_ordinal(aktprocdef.rettype.def) or
is_smallset(aktprocdef.rettype.def)) and
assigned(hp.left) and
assigned(tstatementnode(hp.left).right) and
(tstatementnode(hp.left).right.nodetype=exitn) and
(hp.right.nodetype=assignn) and
assigned(hp.right) and
assigned(tstatementnode(hp.right).left) and
(tstatementnode(hp.right).left.nodetype=exitn) and
(hp.left.nodetype=assignn) and
{ !!!! this tbinarynode should be tassignmentnode }
(tbinarynode(hp.right).left.nodetype=funcretn) then
(tbinarynode(hp.left).left.nodetype=funcretn) then
begin
if assigned(texitnode(tstatementnode(hp.left).right).left) then
if assigned(texitnode(tstatementnode(hp.right).left).left) then
CGMessage(cg_n_inefficient_code)
else
begin
texitnode(tstatementnode(hp.left).right).left:=tstatementnode(hp.right).right;
tstatementnode(hp.right).right:=nil;
hp.right.free;
hp.right:=nil;
texitnode(tstatementnode(hp.right).left).left:=tassignmentnode(hp.left).right;
tassignmentnode(hp.left).right:=nil;
hp.left.free;
hp.left:=nil;
end;
end
{ warning if unreachable code occurs and elimate this }
else if (hp.right.nodetype in
else if (hp.left.nodetype in
[exitn,breakn,continuen,goton]) and
{ statement node (JM) }
assigned(hp.left) and
assigned(hp.right) and
{ kind of statement! (JM) }
assigned(tstatementnode(hp.left).right) and
(tstatementnode(hp.left).right.nodetype<>labeln) then
assigned(tstatementnode(hp.right).left) and
(tstatementnode(hp.right).left.nodetype<>labeln) then
begin
{ use correct line number }
aktfilepos:=hp.left.fileinfo;
hp.left.free;
hp.left:=nil;
aktfilepos:=hp.right.fileinfo;
hp.right.free;
hp.right:=nil;
CGMessage(cg_w_unreachable_code);
{ old lines }
aktfilepos:=hp.right.fileinfo;
aktfilepos:=hp.left.fileinfo;
end;
end;
if assigned(hp.right) then
if assigned(hp.left) then
begin
{$ifndef newra}
rg.cleartempgen;
{$endif}
codegenerror:=false;
firstpass(hp.right);
firstpass(hp.left);
hp.registers32:=hp.right.registers32;
hp.registersfpu:=hp.right.registersfpu;
hp.expectloc:=hp.left.expectloc;
hp.registers32:=hp.left.registers32;
hp.registersfpu:=hp.left.registersfpu;
{$ifdef SUPPORT_MMX}
hp.registersmmx:=hp.right.registersmmx;
hp.registersmmx:=hp.left.registersmmx;
{$endif SUPPORT_MMX}
end
else
@ -427,12 +460,28 @@ implementation
if hp.registersmmx>registersmmx then
registersmmx:=hp.registersmmx;
{$endif}
location.loc:=hp.location.loc;
expectloc:=hp.expectloc;
inc(count);
hp:=tstatementnode(hp.left);
hp:=tstatementnode(hp.right);
end;
end;
{$ifdef state_tracking}
function Tblocknode.track_state_pass(exec_known:boolean):boolean;
var hp:Tstatementnode;
begin
track_state_pass:=false;
hp:=Tstatementnode(left);
while assigned(hp) do
begin
if hp.left.track_state_pass(exec_known) then
track_state_pass:=true;
hp:=Tstatementnode(hp.right);
end;
end;
{$endif state_tracking}
{*****************************************************************************
TASMNODE
@ -452,6 +501,52 @@ implementation
inherited destroy;
end;
constructor tasmnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
var
hp : tai;
begin
inherited ppuload(t,ppufile);
p_asm:=taasmoutput.create;
repeat
hp:=ppuloadai(ppufile);
if hp=nil then
break;
p_asm.concat(hp);
until false;
end;
procedure tasmnode.ppuwrite(ppufile:tcompilerppufile);
var
hp : tai;
begin
inherited ppuwrite(ppufile);
hp:=tai(p_asm.first);
while assigned(hp) do
begin
ppuwriteai(ppufile,hp);
hp:=tai(hp.next);
end;
{ end is marked by a nil }
ppuwriteai(ppufile,nil);
end;
procedure tasmnode.derefimpl;
var
hp : tai;
begin
inherited derefimpl;
hp:=tai(p_asm.first);
while assigned(hp) do
begin
hp.derefimpl;
hp:=tai(hp.next);
end;
end;
function tasmnode.getcopy: tnode;
var
n: tasmnode;
@ -475,22 +570,25 @@ implementation
function tasmnode.pass_1 : tnode;
begin
result:=nil;
procinfo^.flags:=procinfo^.flags or pi_uses_asm;
expectloc:=LOC_VOID;
procinfo.flags:=procinfo.flags or pi_uses_asm;
end;
function tasmnode.docompare(p: tnode): boolean;
begin
{ comparing of asmlists is not implemented (JM) }
docompare := false;
end;
{*****************************************************************************
TEMPCREATENODE
*****************************************************************************}
constructor ttempcreatenode.create(const _restype: ttype; _size: longint; _persistent: boolean);
begin
inherited create(tempn);
inherited create(tempcreaten);
size := _size;
new(tempinfo);
fillchar(tempinfo^,sizeof(tempinfo^),0);
@ -509,17 +607,24 @@ implementation
fillchar(n.tempinfo^,sizeof(n.tempinfo^),0);
n.tempinfo^.restype := tempinfo^.restype;
{ when the tempinfo has already a hookoncopy then it is not
reset by a tempdeletenode }
if assigned(tempinfo^.hookoncopy) then
internalerror(200211262);
{ signal the temprefs that the temp they point to has been copied, }
{ so that if the refs get copied as well, they can hook themselves }
{ to the copy of the temp }
tempinfo^.hookoncopy := n.tempinfo;
tempinfo^.nextref_set_hookoncopy_nil := false;
result := n;
end;
function ttempcreatenode.pass_1 : tnode;
begin
result := nil;
result := nil;
expectloc:=LOC_VOID;
end;
function ttempcreatenode.det_resulttype: tnode;
@ -534,7 +639,7 @@ implementation
result :=
inherited docompare(p) and
(ttempcreatenode(p).size = size) and
is_equal(ttempcreatenode(p).tempinfo^.restype.def,tempinfo^.restype.def);
equal_defs(ttempcreatenode(p).tempinfo^.restype.def,tempinfo^.restype.def);
end;
{*****************************************************************************
@ -559,6 +664,7 @@ implementation
n: ttemprefnode;
begin
n := ttemprefnode(inherited getcopy);
n.offset := offset;
if assigned(tempinfo^.hookoncopy) then
{ if the temp has been copied, assume it becomes a new }
@ -566,6 +672,12 @@ implementation
begin
{ hook the ref to the copied temp }
n.tempinfo := tempinfo^.hookoncopy;
{ if we passed a ttempdeletenode that changed the temp }
{ from a persistent one into a normal one, we must be }
{ the last reference (since our parent should free the }
{ temp (JM) }
if (tempinfo^.nextref_set_hookoncopy_nil) then
tempinfo^.hookoncopy := nil;
end
else
{ if the temp we refer to hasn't been copied, assume }
@ -579,7 +691,7 @@ implementation
function ttemprefnode.pass_1 : tnode;
begin
location.loc:=LOC_REFERENCE;
expectloc:=LOC_REFERENCE;
result := nil;
end;
@ -596,16 +708,24 @@ implementation
begin
result :=
inherited docompare(p) and
(ttemprefnode(p).tempinfo = tempinfo);
(ttemprefnode(p).tempinfo = tempinfo) and
(ttemprefnode(p).offset = offset);
end;
procedure Ttemprefnode.mark_write;
begin
include(flags,nf_write);
end;
{*****************************************************************************
TEMPDELETENODE
*****************************************************************************}
constructor ttempdeletenode.create(const temp: ttempcreatenode);
begin
inherited create(temprefn);
inherited create(tempdeleten);
tempinfo := temp.tempinfo;
release_to_normal := false;
if not temp.persistent then
@ -614,7 +734,7 @@ implementation
constructor ttempdeletenode.create_normal_temp(const temp: ttempcreatenode);
begin
inherited create(temprefn);
inherited create(tempdeleten);
tempinfo := temp.tempinfo;
release_to_normal := true;
end;
@ -624,6 +744,7 @@ implementation
n: ttempdeletenode;
begin
n := ttempdeletenode(inherited getcopy);
n.release_to_normal := release_to_normal;
if assigned(tempinfo^.hookoncopy) then
{ if the temp has been copied, assume it becomes a new }
@ -631,6 +752,13 @@ implementation
begin
{ hook the tempdeletenode to the copied temp }
n.tempinfo := tempinfo^.hookoncopy;
{ the temp shall not be used, reset hookoncopy }
{ Only if release_to_normal is false, otherwise }
{ the temp can still be referenced once more (JM) }
if (not release_to_normal) then
tempinfo^.hookoncopy:=nil
else
tempinfo^.nextref_set_hookoncopy_nil := true;
end
else
{ if the temp we refer to hasn't been copied, we have a }
@ -642,7 +770,8 @@ implementation
function ttempdeletenode.pass_1 : tnode;
begin
result := nil;
expectloc:=LOC_VOID;
result := nil;
end;
function ttempdeletenode.det_resulttype: tnode;
@ -675,7 +804,118 @@ begin
end.
{
$Log$
Revision 1.22 2002-04-23 19:16:34 peter
Revision 1.46 2002-04-25 20:15:39 florian
* block nodes within expressions shouldn't release the used registers,
fixed using a flag till the new rg is ready
Revision 1.45 2003/04/23 08:41:34 jonas
* fixed ttemprefnode.compare and .getcopy to take offset field into
account
Revision 1.44 2003/04/22 23:50:22 peter
* firstpass uses expectloc
* checks if there are differences between the expectloc and
location.loc from secondpass in EXTDEBUG
Revision 1.43 2003/04/21 15:00:22 jonas
* fixed tstatementnode.det_resulttype and tststatementnode.pass_1
* fixed some getcopy issues with ttemp*nodes
Revision 1.42 2003/04/17 07:50:24 daniel
* Some work on interference graph construction
Revision 1.41 2003/04/12 14:53:59 jonas
* ttempdeletenode.create now sets the nodetype to tempdeleten instead of
temprefn
Revision 1.40 2003/03/17 20:30:46 peter
* errornode.mark_write added
Revision 1.39 2003/01/03 12:15:55 daniel
* Removed ifdefs around notifications
ifdefs around for loop optimizations remain
Revision 1.38 2002/11/27 02:37:12 peter
* case statement inlining added
* fixed inlining of write()
* switched statementnode left and right parts so the statements are
processed in the correct order when getcopy is used. This is
required for tempnodes
Revision 1.37 2002/11/25 17:43:17 peter
* splitted defbase in defutil,symutil,defcmp
* merged isconvertable and is_equal into compare_defs(_ext)
* made operator search faster by walking the list only once
Revision 1.36 2002/10/05 15:15:19 peter
* don't complain in X- mode for internal generated function calls
with funcretrefnode set
* give statement error at the correct line position instead of the
block begin
Revision 1.35 2002/09/01 08:01:16 daniel
* Removed sets from Tcallnode.det_resulttype
+ Added read/write notifications of variables. These will be usefull
for providing information for several optimizations. For example
the value of the loop variable of a for loop does matter is the
variable is read after the for loop, but if it's no longer used
or written, it doesn't matter and this can be used to optimize
the loop code generation.
Revision 1.34 2002/08/18 20:06:23 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu
* nld,ncon,nbas are already updated for storing in ppu
Revision 1.33 2002/08/17 22:09:44 florian
* result type handling in tcgcal.pass_2 overhauled
* better tnode.dowrite
* some ppc stuff fixed
Revision 1.32 2002/08/17 09:23:34 florian
* first part of procinfo rewrite
Revision 1.31 2002/08/15 19:10:35 peter
* first things tai,tnode storing in ppu
Revision 1.30 2002/07/20 11:57:53 florian
* types.pas renamed to defbase.pas because D6 contains a types
unit so this would conflicts if D6 programms are compiled
+ Willamette/SSE2 instructions to assembler added
Revision 1.29 2002/07/19 11:41:35 daniel
* State tracker work
* The whilen and repeatn are now completely unified into whilerepeatn. This
allows the state tracker to change while nodes automatically into
repeat nodes.
* Resulttypepass improvements to the notn. 'not not a' is optimized away and
'not(a>b)' is optimized into 'a<=b'.
* Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
by removing the notn and later switchting the true and falselabels. The
same is done with 'repeat until not a'.
Revision 1.28 2002/07/14 18:00:43 daniel
+ Added the beginning of a state tracker. This will track the values of
variables through procedures and optimize things away.
Revision 1.27 2002/07/01 18:46:22 peter
* internal linker
* reorganized aasm layer
Revision 1.26 2002/06/24 12:43:00 jonas
* fixed errors found with new -CR code from Peter when cycling with -O2p3r
Revision 1.25 2002/05/18 13:34:09 peter
* readded missing revisions
Revision 1.24 2002/05/16 19:46:37 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.22 2002/04/23 19:16:34 peter
* add pinline unit that inserts compiler supported functions using
one or more statements
* moved finalize and setlength from ninl to pinline
@ -708,82 +948,4 @@ end.
- list field removed of the tnode class because it's not used currently
and can cause hard-to-find bugs
Revision 1.18 2001/11/02 22:58:01 peter
* procsym definition rewrite
Revision 1.17 2001/09/02 21:12:06 peter
* move class of definitions into type section for delphi
Revision 1.16 2001/08/26 13:36:38 florian
* some cg reorganisation
* some PPC updates
Revision 1.15 2001/08/24 13:47:26 jonas
* moved "reverseparameters" from ninl.pas to ncal.pas
+ support for non-persistent temps in ttempcreatenode.create, for use
with typeconversion nodes
Revision 1.14 2001/08/23 14:28:35 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.13 2001/08/06 21:40:46 peter
* funcret moved from tprocinfo to tprocdef
Revision 1.12 2001/06/11 17:41:12 jonas
* fixed web bug 1501 in conjunction with -Or
Revision 1.11 2001/05/18 22:31:06 peter
* tasmnode.pass_2 is independent of cpu, moved to ncgbas
* include ncgbas for independent nodes
Revision 1.10 2001/04/13 01:22:08 peter
* symtable change to classes
* range check generation and errors fixed, make cycle DEBUG=1 works
* memory leaks fixed
Revision 1.9 2001/04/02 21:20:30 peter
* resulttype rewrite
Revision 1.8 2001/02/05 20:45:49 peter
* fixed buf 1364
Revision 1.7 2000/12/31 11:14:10 jonas
+ implemented/fixed docompare() mathods for all nodes (not tested)
+ nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
and constant strings/chars together
* n386add.pas: don't copy temp strings (of size 256) to another temp string
when adding
Revision 1.6 2000/12/25 00:07:26 peter
+ new tlinkedlist class (merge of old tstringqueue,tcontainer and
tlinkedlist objects)
Revision 1.5 2000/11/29 00:30:31 florian
* unused units removed from uses clause
* some changes for widestrings
Revision 1.4 2000/10/31 22:02:47 peter
* symtable splitted, no real code changes
Revision 1.3 2000/10/27 14:57:16 jonas
+ implementation for tasmnode.getcopy
Revision 1.2 2000/10/14 21:52:54 peter
* fixed memory leaks
Revision 1.1 2000/10/14 10:14:50 peter
* moehrendorf oct 2000 rewrite
}

3293
compiler/ncal.pas
View File

File diff suppressed because it is too large Load Diff

241
compiler/ncgbas.pas
View File

@ -1,6 +1,6 @@
{
$Id$
Copyright (c) 2000 by Florian Klaempfl
Copyright (c) 2000-2002 by Florian Klaempfl
This unit implements some basic nodes
@ -22,7 +22,7 @@
}
unit ncgbas;
{$i defines.inc}
{$i fpcdefs.inc}
interface
@ -63,18 +63,20 @@ interface
uses
globtype,systems,
cutils,verbose,globals,
aasm,symsym,
cpubase,cpuasm,
aasmbase,aasmtai,aasmcpu,symsym,
cpubase,
nflw,pass_2,
cga,
cgbase,tgobj,rgobj
cgbase,cginfo,cgobj,tgobj,rgobj
;
{*****************************************************************************
TNOTHING
*****************************************************************************}
procedure tcgnothingnode.pass_2;
begin
location_reset(location,LOC_VOID,OS_NO);
{ avoid an abstract rte }
end;
@ -85,19 +87,23 @@ interface
procedure tcgstatementnode.pass_2;
var
hp : tnode;
hp : tstatementnode;
begin
location_reset(location,LOC_VOID,OS_NO);
hp:=self;
while assigned(hp) do
begin
if assigned(tstatementnode(hp).right) then
if assigned(hp.left) then
begin
{$ifndef newra}
rg.cleartempgen;
secondpass(tstatementnode(hp).right);
{$endif newra}
secondpass(hp.left);
{ Compiler inserted blocks can return values }
location_copy(location,tstatementnode(hp).right.location);
location_copy(hp.location,hp.left.location);
end;
hp:=tstatementnode(hp).left;
hp:=tstatementnode(hp.right);
end;
end;
@ -110,21 +116,14 @@ interface
procedure ReLabel(var p:tasmsymbol);
begin
if p.proclocal then
{ Only relabel local tasmlabels }
if (p.defbind = AB_LOCAL) and
(p is tasmlabel) then
begin
if not assigned(p.altsymbol) then
begin
{ generatealtsymbol will also increase the refs }
p.GenerateAltSymbol;
UsedAsmSymbolListInsert(p);
end
else
begin
{ increase the refs, they will be decreased when the
asmnode is destroyed }
inc(p.refs);
end;
objectlibrary.GenerateAltSymbol(p);
p:=p.altsymbol;
p.increfs;
end;
end;
@ -134,9 +133,11 @@ interface
i : longint;
skipnode : boolean;
begin
location_reset(location,LOC_VOID,OS_NO);
if inlining_procedure then
begin
CreateUsedAsmSymbolList;
objectlibrary.CreateUsedAsmSymbolList;
localfixup:=aktprocdef.localst.address_fixup;
parafixup:=aktprocdef.parast.address_fixup;
hp:=tai(p_asm.first);
@ -159,7 +160,11 @@ interface
begin
{ remove cached insentry, because the new code can
require an other less optimized instruction }
{$ifdef i386}
{$ifndef NOAG386BIN}
taicpu(hp2).ResetPass1;
{$endif}
{$endif}
{ fixup the references }
for i:=1 to taicpu(hp2).ops do
begin
@ -200,8 +205,8 @@ interface
hp:=tai(hp.next);
end;
{ restore used symbols }
UsedAsmSymbolListResetAltSym;
DestroyUsedAsmSymbolList;
objectlibrary.UsedAsmSymbolListResetAltSym;
objectlibrary.DestroyUsedAsmSymbolList;
end
else
begin
@ -212,8 +217,6 @@ interface
else
exprasmList.concatlist(p_asm);
end;
if not (nf_object_preserved in flags) then
maybe_loadself;
end;
@ -222,13 +225,29 @@ interface
*****************************************************************************}
procedure tcgblocknode.pass_2;
var
hp : tstatementnode;
begin
location_reset(location,LOC_VOID,OS_NO);
{ do second pass on left node }
if assigned(left) then
begin
secondpass(left);
{ Compiler inserted blocks can return values }
location_copy(location,left.location);
hp:=tstatementnode(left);
while assigned(hp) do
begin
if assigned(hp.left) then
begin
{$ifndef newra}
if nf_releasetemps in flags then
rg.cleartempgen;
{$endif newra}
secondpass(hp.left);
location_copy(hp.location,hp.left.location);
end;
location_copy(location,hp.location);
hp:=tstatementnode(hp.right);
end;
end;
end;
@ -237,16 +256,21 @@ interface
*****************************************************************************}
procedure tcgtempcreatenode.pass_2;
var
temptype : ttemptype;
begin
location_reset(location,LOC_VOID,OS_NO);
{ if we're secondpassing the same tcgtempcreatenode twice, we have a bug }
if tempinfo^.valid then
internalerror(200108222);
{ get a (persistent) temp }
if persistent then
tg.gettempofsizereferencepersistant(exprasmlist,size,tempinfo^.ref)
temptype:=tt_persistant
else
tg.gettempofsizereference(exprasmlist,size,tempinfo^.ref);
temptype:=tt_normal;
tg.GetTemp(exprasmlist,size,temptype,tempinfo^.ref);
tempinfo^.valid := true;
end;
@ -272,10 +296,12 @@ interface
procedure tcgtempdeletenode.pass_2;
begin
location_reset(location,LOC_VOID,OS_NO);
if release_to_normal then
tg.persistanttemptonormal(tempinfo^.ref.offset)
tg.ChangeTempType(exprasmlist,tempinfo^.ref,tt_normal)
else
tg.ungetpersistanttempreference(exprasmlist,tempinfo^.ref);
tg.UnGetTemp(exprasmlist,tempinfo^.ref);
end;
@ -290,7 +316,102 @@ begin
end.
{
$Log$
Revision 1.14 2002-04-23 19:16:34 peter
Revision 1.32 2002-04-25 20:15:39 florian
* block nodes within expressions shouldn't release the used registers,
fixed using a flag till the new rg is ready
Revision 1.31 2003/04/22 23:50:22 peter
* firstpass uses expectloc
* checks if there are differences between the expectloc and
location.loc from secondpass in EXTDEBUG
Revision 1.30 2003/04/17 07:50:24 daniel
* Some work on interference graph construction
Revision 1.29 2003/03/28 19:16:56 peter
* generic constructor working for i386
* remove fixed self register
* esi added as address register for i386
Revision 1.28 2002/11/27 15:33:19 peter
* fixed relabeling to relabel only tasmlabel (formerly proclocal)
Revision 1.27 2002/11/27 02:37:13 peter
* case statement inlining added
* fixed inlining of write()
* switched statementnode left and right parts so the statements are
processed in the correct order when getcopy is used. This is
required for tempnodes
Revision 1.26 2002/11/17 16:31:56 carl
* memory optimization (3-4%) : cleanup of tai fields,
cleanup of tdef and tsym fields.
* make it work for m68k
Revision 1.25 2002/11/15 16:29:30 peter
* made tasmsymbol.refs private (merged)
Revision 1.24 2002/11/15 01:58:51 peter
* merged changes from 1.0.7 up to 04-11
- -V option for generating bug report tracing
- more tracing for option parsing
- errors for cdecl and high()
- win32 import stabs
- win32 records<=8 are returned in eax:edx (turned off by default)
- heaptrc update
- more info for temp management in .s file with EXTDEBUG
Revision 1.23 2002/08/23 16:14:48 peter
* tempgen cleanup
* tt_noreuse temp type added that will be used in genentrycode
Revision 1.22 2002/08/11 14:32:26 peter
* renamed current_library to objectlibrary
Revision 1.21 2002/08/11 13:24:11 peter
* saving of asmsymbols in ppu supported
* asmsymbollist global is removed and moved into a new class
tasmlibrarydata that will hold the info of a .a file which
corresponds with a single module. Added librarydata to tmodule
to keep the library info stored for the module. In the future the
objectfiles will also be stored to the tasmlibrarydata class
* all getlabel/newasmsymbol and friends are moved to the new class
Revision 1.20 2002/07/01 18:46:22 peter
* internal linker
* reorganized aasm layer
Revision 1.19 2002/05/18 13:34:09 peter
* readded missing revisions
Revision 1.18 2002/05/16 19:46:37 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.16 2002/05/13 19:54:37 peter
* removed n386ld and n386util units
* maybe_save/maybe_restore added instead of the old maybe_push
Revision 1.15 2002/05/12 16:53:07 peter
* moved entry and exitcode to ncgutil and cgobj
* foreach gets extra argument for passing local data to the
iterator function
* -CR checks also class typecasts at runtime by changing them
into as
* fixed compiler to cycle with the -CR option
* fixed stabs with elf writer, finally the global variables can
be watched
* removed a lot of routines from cga unit and replaced them by
calls to cgobj
* u32bit-s32bit updates for and,or,xor nodes. When one element is
u32bit then the other is typecasted also to u32bit without giving
a rangecheck warning/error.
* fixed pascal calling method with reversing also the high tree in
the parast, detected by tcalcst3 test
Revision 1.14 2002/04/23 19:16:34 peter
* add pinline unit that inserts compiler supported functions using
one or more statements
* moved finalize and setlength from ninl to pinline
@ -323,52 +444,4 @@ end.
- list field removed of the tnode class because it's not used currently
and can cause hard-to-find bugs
Revision 1.10 2001/12/31 16:54:14 peter
* fixed inline crash with assembler routines
Revision 1.9 2001/11/02 22:58:01 peter
* procsym definition rewrite
Revision 1.8 2001/10/25 21:22:35 peter
* calling convention rewrite
Revision 1.7 2001/08/26 13:36:39 florian
* some cg reorganisation
* some PPC updates
Revision 1.6 2001/08/24 13:47:27 jonas
* moved "reverseparameters" from ninl.pas to ncal.pas
+ support for non-persistent temps in ttempcreatenode.create, for use
with typeconversion nodes
Revision 1.5 2001/08/23 14:28:35 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.4 2001/06/02 19:22:15 peter
* refs count for relabeled asmsymbols fixed
Revision 1.3 2001/05/18 22:31:06 peter
* tasmnode.pass_2 is independent of cpu, moved to ncgbas
* include ncgbas for independent nodes
Revision 1.2 2001/04/13 01:22:08 peter
* symtable change to classes
* range check generation and errors fixed, make cycle DEBUG=1 works
* memory leaks fixed
Revision 1.1 2000/10/14 10:14:50 peter
* moehrendorf oct 2000 rewrite
}

1259
compiler/ninl.pas
View File

File diff suppressed because it is too large Load Diff

790
compiler/node.pas
View File

File diff suppressed because it is too large Load Diff

192
compiler/pinline.pas
View File

@ -1,6 +1,6 @@
{
$Id$
Copyright (c) 1998-2001 by Florian Klaempfl
Copyright (c) 1998-2002 by Florian Klaempfl
Generates nodes for routines that need compiler support
@ -22,7 +22,7 @@
}
unit pinline;
{$i defines.inc}
{$i fpcdefs.inc}
interface
@ -37,6 +37,7 @@ interface
function inline_setlength : tnode;
function inline_finalize : tnode;
function inline_copy : tnode;
implementation
@ -49,9 +50,9 @@ implementation
cutils,
{ global }
globtype,tokens,verbose,
systems,widestr,
systems,
{ symtable }
symconst,symbase,symdef,symsym,symtable,types,
symconst,symdef,symsym,symtable,defutil,
{ pass 1 }
pass_1,htypechk,
nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,
@ -169,6 +170,15 @@ implementation
{ we need the real called method }
{ rg.cleartempgen;}
do_resulttypepass(p2);
if p2.nodetype<>calln then
begin
if is_new then
CGMessage(parser_e_expr_have_to_be_constructor_call)
else
CGMessage(parser_e_expr_have_to_be_destructor_call);
end;
if not codegenerror then
begin
if is_new then
@ -211,7 +221,7 @@ implementation
{ create statements with call to getmem+initialize or
finalize+freemem }
new_dispose_statement:=internalstatements(newstatement);
new_dispose_statement:=internalstatements(newstatement,true);
if is_new then
begin
@ -221,7 +231,7 @@ implementation
{ create call to fpc_getmem }
para := ccallparanode.create(cordconstnode.create
(tpointerdef(p.resulttype.def).pointertype.def.size,s32bittype),nil);
(tpointerdef(p.resulttype.def).pointertype.def.size,s32bittype,true),nil);
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create(temp),
ccallnode.createintern('fpc_getmem',para)));
@ -297,7 +307,7 @@ implementation
Message(parser_w_use_extended_syntax_for_objects);
{ create statements with call to getmem+initialize }
newblock:=internalstatements(newstatement);
newblock:=internalstatements(newstatement,true);
{ create temp for result }
temp := ctempcreatenode.create(p1.resulttype,p1.resulttype.def.size,true);
@ -305,7 +315,7 @@ implementation
{ create call to fpc_getmem }
para := ccallparanode.create(cordconstnode.create
(tpointerdef(p1.resulttype.def).pointertype.def.size,s32bittype),nil);
(tpointerdef(p1.resulttype.def).pointertype.def.size,s32bittype,true),nil);
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create(temp),
ccallnode.createintern('fpc_getmem',para)));
@ -455,7 +465,7 @@ implementation
begin
{ create statements with call initialize the arguments and
call fpc_dynarr_setlength }
newblock:=internalstatements(newstatement);
newblock:=internalstatements(newstatement,true);
{ get temp for array of lengths }
temp := ctempcreatenode.create(s32bittype,counter*s32bittype.def.size,true);
@ -480,7 +490,7 @@ implementation
npara:=ccallparanode.create(caddrnode.create
(ctemprefnode.create(temp)),
ccallparanode.create(cordconstnode.create
(counter,s32bittype),
(counter,s32bittype,true),
ccallparanode.create(caddrnode.create
(crttinode.create(tstoreddef(destppn.resulttype.def),initrtti)),
ccallparanode.create(ctypeconvnode.create_explicit(destppn,voidpointertype),nil))));
@ -536,7 +546,7 @@ implementation
end;
{ create call to fpc_finalize_array }
npara:=ccallparanode.create(cordconstnode.create
(destppn.left.resulttype.def.size,s32bittype),
(destppn.left.resulttype.def.size,s32bittype,true),
ccallparanode.create(ctypeconvnode.create
(ppn.left,s32bittype),
ccallparanode.create(caddrnode.create
@ -562,10 +572,168 @@ implementation
result:=newblock;
end;
function inline_copy : tnode;
var
copynode,
lowppn,
highppn,
npara,
paras : tnode;
temp : ttempcreatenode;
ppn : tcallparanode;
paradef : tdef;
counter : integer;
newstatement : tstatementnode;
begin
{ for easy exiting if something goes wrong }
result := cerrornode.create;
consume(_LKLAMMER);
paras:=parse_paras(false,false);
consume(_RKLAMMER);
if not assigned(paras) then
begin
CGMessage(parser_e_wrong_parameter_size);
exit;
end;
{ determine copy function to use based on the first argument,
also count the number of arguments in this loop }
counter:=1;
ppn:=tcallparanode(paras);
while assigned(ppn.right) do
begin
inc(counter);
ppn:=tcallparanode(ppn.right);
end;
paradef:=ppn.left.resulttype.def;
if is_ansistring(paradef) then
copynode:=ccallnode.createintern('fpc_ansistr_copy',paras)
else
if is_widestring(paradef) then
copynode:=ccallnode.createintern('fpc_widestr_copy',paras)
else
if is_char(paradef) then
copynode:=ccallnode.createintern('fpc_char_copy',paras)
else
if is_dynamic_array(paradef) then
begin
{ Only allow 1 or 3 arguments }
if (counter<>1) and (counter<>3) then
begin
CGMessage(parser_e_wrong_parameter_size);
exit;
end;
{ create statements with call }
copynode:=internalstatements(newstatement,true);
if (counter=3) then
begin
highppn:=tcallparanode(paras).left.getcopy;
lowppn:=tcallparanode(tcallparanode(paras).right).left.getcopy;
end
else
begin
{ use special -1,-1 argument to copy the whole array }
highppn:=cordconstnode.create(-1,s32bittype,false);
lowppn:=cordconstnode.create(-1,s32bittype,false);
end;
{ create temp for result, we've to use a temp because a dynarray
type is handled differently from a pointer so we can't
use createinternres() and a function }
temp := ctempcreatenode.create(voidpointertype,voidpointertype.def.size,true);
addstatement(newstatement,temp);
{ create call to fpc_dynarray_copy }
npara:=ccallparanode.create(highppn,
ccallparanode.create(lowppn,
ccallparanode.create(caddrnode.create
(crttinode.create(tstoreddef(ppn.left.resulttype.def),initrtti)),
ccallparanode.create
(ctypeconvnode.create_explicit(ppn.left,voidpointertype),
ccallparanode.create
(ctemprefnode.create(temp),nil)))));
addstatement(newstatement,ccallnode.createintern('fpc_dynarray_copy',npara));
{ convert the temp to normal and return the reference to the
created temp, and convert the type of the temp to the dynarray type }
addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
addstatement(newstatement,ctypeconvnode.create_explicit(ctemprefnode.create(temp),ppn.left.resulttype));
ppn.left:=nil;
paras.free;
end
else
begin
{ generic fallback that will give an error if a wrong
type is passed }
copynode:=ccallnode.createintern('fpc_shortstr_copy',paras)
end;
result.free;
result:=copynode;
end;
end.
{
$Log$
Revision 1.1 2002-04-23 19:16:35 peter
Revision 1.12 2002-04-25 20:15:40 florian
* block nodes within expressions shouldn't release the used registers,
fixed using a flag till the new rg is ready
Revision 1.11 2002/11/26 22:59:09 peter
* fix Copy(array,x,y)
Revision 1.10 2002/11/25 17:43:22 peter
* splitted defbase in defutil,symutil,defcmp
* merged isconvertable and is_equal into compare_defs(_ext)
* made operator search faster by walking the list only once
Revision 1.9 2002/10/29 10:01:22 pierre
* fix crash report as webbug 2174
Revision 1.8 2002/10/02 18:20:52 peter
* Copy() is now internal syssym that calls compilerprocs
Revision 1.7 2002/09/07 12:16:03 carl
* second part bug report 1996 fix, testrange in cordconstnode
only called if option is set (also make parsing a tiny faster)
Revision 1.6 2002/07/20 11:57:56 florian
* types.pas renamed to defbase.pas because D6 contains a types
unit so this would conflicts if D6 programms are compiled
+ Willamette/SSE2 instructions to assembler added
Revision 1.5 2002/05/18 13:34:12 peter
* readded missing revisions
Revision 1.4 2002/05/16 19:46:43 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.2 2002/05/12 16:53:09 peter
* moved entry and exitcode to ncgutil and cgobj
* foreach gets extra argument for passing local data to the
iterator function
* -CR checks also class typecasts at runtime by changing them
into as
* fixed compiler to cycle with the -CR option
* fixed stabs with elf writer, finally the global variables can
be watched
* removed a lot of routines from cga unit and replaced them by
calls to cgobj
* u32bit-s32bit updates for and,or,xor nodes. When one element is
u32bit then the other is typecasted also to u32bit without giving
a rangecheck warning/error.
* fixed pascal calling method with reversing also the high tree in
the parast, detected by tcalcst3 test
Revision 1.1 2002/04/23 19:16:35 peter
* add pinline unit that inserts compiler supported functions using
one or more statements
* moved finalize and setlength from ninl to pinline

587
compiler/pstatmnt.pas
View File

@ -1,6 +1,6 @@
{
$Id$
Copyright (c) 1998-2000 by Florian Klaempfl
Copyright (c) 1998-2002 by Florian Klaempfl
Does the parsing of the statements
@ -22,7 +22,7 @@
}
unit pstatmnt;
{$i defines.inc}
{$i fpcdefs.inc}
interface
uses
@ -42,11 +42,12 @@ implementation
cutils,
{ global }
globtype,globals,verbose,
systems,cpuinfo,cpuasm,
systems,cpuinfo,
{ aasm }
cpubase,aasm,
cpubase,aasmbase,aasmtai,aasmcpu,
{ symtable }
symconst,symbase,symtype,symdef,symsym,symtable,types,
symconst,symbase,symtype,symdef,symsym,symtable,defutil,defcmp,
paramgr,
{ pass 1 }
pass_1,htypechk,
nbas,nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
@ -54,7 +55,9 @@ implementation
scanner,
pbase,pexpr,
{ codegen }
rgobj,cgbase
tgobj,rgobj,cgbase
,ncgutil
,radirect
{$ifdef i386}
{$ifndef NoRa386Int}
,ra386int
@ -62,19 +65,9 @@ implementation
{$ifndef NoRa386Att}
,ra386att
{$endif NoRa386Att}
{$ifndef NoRa386Dir}
,ra386dir
{$endif NoRa386Dir}
{$else}
,rasm
{$endif i386}
{$ifdef m68k}
{$ifndef NoRa68kMot}
,ra68kmot
{$endif NoRa68kMot}
{$endif m68k}
{ codegen }
{$ifdef newcg}
,cgbase
{$endif newcg}
;
@ -112,20 +105,20 @@ implementation
begin
if first=nil then
begin
last:=cstatementnode.create(nil,statement);
last:=cstatementnode.create(statement,nil);
first:=last;
end
else
begin
last.left:=cstatementnode.create(nil,statement);
last:=tstatementnode(last.left);
last.right:=cstatementnode.create(statement,nil);
last:=tstatementnode(last.right);
end;
if not try_to_consume(_SEMICOLON) then
break;
consume_emptystats;
end;
consume(_END);
statements_til_end:=cblocknode.create(first);
statements_til_end:=cblocknode.create(first,true);
end;
@ -179,7 +172,7 @@ implementation
hcaselabel^.greater:=nil;
hcaselabel^.statement:=aktcaselabel;
hcaselabel^.firstlabel:=first;
getlabel(hcaselabel^._at);
objectlibrary.getlabel(hcaselabel^._at);
hcaselabel^._low:=l;
hcaselabel^._high:=h;
insertlabel(root);
@ -194,7 +187,9 @@ implementation
consume(_CASE);
caseexpr:=comp_expr(true);
{ determines result type }
{$ifndef newra}
rg.cleartempgen;
{$endif}
do_resulttypepass(caseexpr);
casedeferror:=false;
casedef:=caseexpr.resulttype.def;
@ -204,7 +199,7 @@ implementation
CGMessage(type_e_ordinal_expr_expected);
{ create a correct tree }
caseexpr.free;
caseexpr:=cordconstnode.create(0,u32bittype);
caseexpr:=cordconstnode.create(0,u32bittype,false);
{ set error flag so no rangechecks are done }
casedeferror:=true;
end;
@ -214,7 +209,7 @@ implementation
root:=nil;
instruc:=nil;
repeat
getlabel(aktcaselabel);
objectlibrary.getlabel(aktcaselabel);
firstlabel:=true;
{ maybe an instruction has more case labels }
@ -281,13 +276,13 @@ implementation
p:=clabelnode.createcase(aktcaselabel,statement);
{ concats instruction }
instruc:=cstatementnode.create(instruc,p);
instruc:=cstatementnode.create(p,instruc);
if not((token=_ELSE) or (token=_OTHERWISE) or (token=_END)) then
if not(token in [_ELSE,_OTHERWISE,_END]) then
consume(_SEMICOLON);
until (token=_ELSE) or (token=_OTHERWISE) or (token=_END);
until (token in [_ELSE,_OTHERWISE,_END]);
if (token=_ELSE) or (token=_OTHERWISE) then
if (token in [_ELSE,_OTHERWISE]) then
begin
if not try_to_consume(_ELSE) then
consume(_OTHERWISE);
@ -322,13 +317,13 @@ implementation
begin
if first=nil then
begin
last:=cstatementnode.create(nil,statement);
last:=cstatementnode.create(statement,nil);
first:=last;
end
else
begin
tstatementnode(last).left:=cstatementnode.create(nil,statement);
last:=tstatementnode(last).left;
tstatementnode(last).right:=cstatementnode.create(statement,nil);
last:=tstatementnode(last).right;
end;
if not try_to_consume(_SEMICOLON) then
break;
@ -337,9 +332,9 @@ implementation
consume(_UNTIL);
dec(statement_level);
first:=cblocknode.create(first);
first:=cblocknode.create(first,true);
p_e:=comp_expr(true);
repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
repeat_statement:=genloopnode(whilerepeatn,p_e,first,nil,true);
end;
@ -353,7 +348,7 @@ implementation
p_e:=comp_expr(true);
consume(_DO);
p_a:=statement;
while_statement:=genloopnode(whilen,p_e,p_a,nil,false);
while_statement:=genloopnode(whilerepeatn,p_e,p_a,nil,false);
end;
@ -495,7 +490,7 @@ implementation
paddr:=nil;
pframe:=nil;
consume(_RAISE);
if not(token in [_SEMICOLON,_END]) then
if not(token in endtokens) then
begin
{ object }
pobj:=comp_expr(true);
@ -531,7 +526,7 @@ implementation
oldaktexceptblock: integer;
begin
procinfo^.flags:=procinfo^.flags or pi_uses_exceptions;
procinfo.flags:=procinfo.flags or pi_uses_exceptions;
p_default:=nil;
p_specific:=nil;
@ -548,19 +543,19 @@ implementation
begin
if first=nil then
begin
last:=cstatementnode.create(nil,statement);
last:=cstatementnode.create(statement,nil);
first:=last;
end
else
begin
tstatementnode(last).left:=cstatementnode.create(nil,statement);
last:=tstatementnode(last).left;
tstatementnode(last).right:=cstatementnode.create(statement,nil);
last:=tstatementnode(last).right;
end;
if not try_to_consume(_SEMICOLON) then
break;
consume_emptystats;
end;
p_try_block:=cblocknode.create(first);
p_try_block:=cblocknode.create(first,true);
if try_to_consume(_FINALLY) then
begin
@ -690,19 +685,18 @@ implementation
if not try_to_consume(_SEMICOLON) then
break;
consume_emptystats;
until (token=_END) or (token=_ELSE);
if token=_ELSE then
{ catch the other exceptions }
until (token in [_END,_ELSE]);
if try_to_consume(_ELSE) then
begin
consume(_ELSE);
p_default:=statements_til_end;
{ catch the other exceptions }
p_default:=statements_til_end;
end
else
consume(_END);
end
else
{ catch all exceptions }
begin
{ catch all exceptions }
p_default:=statements_til_end;
end;
dec(statement_level);
@ -714,34 +708,13 @@ implementation
end;
function exit_statement : tnode;
var
p : tnode;
begin
consume(_EXIT);
if try_to_consume(_LKLAMMER) then
begin
p:=comp_expr(true);
consume(_RKLAMMER);
if (block_type=bt_except) then
Message(parser_e_exit_with_argument_not__possible);
if is_void(aktprocdef.rettype.def) then
Message(parser_e_void_function);
end
else
p:=nil;
p:=cexitnode.create(p);
do_resulttypepass(p);
exit_statement:=p;
end;
function _asm_statement : tnode;
var
asmstat : tasmnode;
Marker : tai;
Marker : tai;
r : tregister;
found : boolean;
hs : string;
begin
Inside_asm_statement:=true;
case aktasmmode of
@ -756,8 +729,11 @@ implementation
asmmode_i386_intel:
asmstat:=tasmnode(ra386int.assemble);
{$endif NoRA386Int}
{$ifndef NoRA386Dir}
asmmode_i386_direct:
{$else not i386}
asmmode_standard:
asmstat:=tasmnode(rasm.assemble);
{$endif i386}
asmmode_direct:
begin
if not target_asm.allowdirect then
Message(parser_f_direct_assembler_not_allowed);
@ -767,16 +743,9 @@ implementation
Message(parser_w_inlining_disabled);
aktprocdef.proccalloption:=pocall_fpccall;
End;
asmstat:=tasmnode(ra386dir.assemble);
asmstat:=tasmnode(radirect.assemble);
end;
{$endif NoRA386Dir}
{$endif}
{$ifdef m68k}
{$ifndef NoRA68kMot}
asmmode_m68k_mot:
asmstat:=tasmnode(ra68kmot.assemble);
{$endif NoRA68kMot}
{$endif}
else
Message(parser_f_assembler_reader_not_supported);
end;
@ -787,71 +756,34 @@ implementation
{ END is read }
if try_to_consume(_LECKKLAMMER) then
begin
{ it's possible to specify the modified registers }
include(asmstat.flags,nf_object_preserved);
if token<>_RECKKLAMMER then
if token<>_RECKKLAMMER then
begin
repeat
{ uppercase, because it's a CSTRING }
uppervar(pattern);
{$ifdef i386}
if pattern='EAX' then
include(rg.usedinproc,R_EAX)
else if pattern='EBX' then
include(rg.usedinproc,R_EBX)
else if pattern='ECX' then
include(rg.usedinproc,R_ECX)
else if pattern='EDX' then
include(rg.usedinproc,R_EDX)
else if pattern='ESI' then
{ it's possible to specify the modified registers }
hs:=upper(pattern);
found:=false;
for r.enum:=firstreg to lastreg do
if hs=upper(std_reg2str[r.enum]) then
begin
include(rg.usedinproc,R_ESI);
exclude(asmstat.flags,nf_object_preserved);
end
else if pattern='EDI' then
include(rg.usedinproc,R_EDI)
{$endif i386}
{$ifdef m68k}
if pattern='D0' then
include(rg.usedinproc,R_D0)
else if pattern='D1' then
include(rg.usedinproc,R_D1)
else if pattern='D2' then
include(rg.usedinproc,R_D2)
else if pattern='D3' then
include(rg.usedinproc,R_D3)
else if pattern='D4' then
include(rg.usedinproc,R_D4)
else if pattern='D5' then
include(rg.usedinproc,R_D5)
else if pattern='D6' then
include(rg.usedinproc,R_D6)
else if pattern='D7' then
include(rg.usedinproc,R_D7)
else if pattern='A0' then
include(rg.usedinproc,R_A0)
else if pattern='A1' then
include(rg.usedinproc,R_A1)
else if pattern='A2' then
include(rg.usedinproc,R_A2)
else if pattern='A3' then
include(rg.usedinproc,R_A3)
else if pattern='A4' then
include(rg.usedinproc,R_A4)
else if pattern='A5' then
include(rg.usedinproc,R_A5)
{$endif m68k}
{$ifdef powerpc}
if pattern<>'' then
internalerror(200108251)
{$endif powerpc}
else consume(_RECKKLAMMER);
include(rg.usedinproc,r.enum);
include(rg.usedbyproc,r.enum);
found:=true;
break;
end;
if not(found) then
Message(asmr_e_invalid_register);
consume(_CSTRING);
if not try_to_consume(_COMMA) then
break;
until false;
consume(_RECKKLAMMER);
end;
consume(_RECKKLAMMER);
end
else rg.usedinproc := ALL_REGISTERS;
else
begin
rg.usedbyproc := ALL_REGISTERS;
rg.usedinproc := ALL_REGISTERS;
end;
{ mark the start and the end of the assembler block
this is needed for the optimizer }
@ -949,8 +881,6 @@ implementation
consume(_FAIL);
code:=cfailnode.create;
end;
_EXIT :
code:=exit_statement;
_ASM :
code:=_asm_statement;
_EOF :
@ -992,7 +922,7 @@ implementation
{ with a separate statement for each read/write operation (JM) }
{ the same is true for val() if the third parameter is not 32 bit }
if not(p.nodetype in [nothingn,calln,assignn,breakn,inlinen,
continuen,labeln,blockn]) then
continuen,labeln,blockn,exitn]) then
Message(cg_e_illegal_expression);
{ specify that we don't use the value returned by the call }
@ -1029,13 +959,13 @@ implementation
begin
if first=nil then
begin
last:=cstatementnode.create(nil,statement);
last:=cstatementnode.create(statement,nil);
first:=last;
end
else
begin
tstatementnode(last).left:=cstatementnode.create(nil,statement);
last:=tstatementnode(last).left;
tstatementnode(last).right:=cstatementnode.create(statement,nil);
last:=tstatementnode(last).right;
end;
if (token in [_END,_FINALIZATION]) then
break
@ -1060,7 +990,7 @@ implementation
dec(statement_level);
last:=cblocknode.create(first);
last:=cblocknode.create(first,true);
last.set_tree_filepos(filepos);
statement_block:=last;
end;
@ -1081,11 +1011,15 @@ implementation
parafixup,
i : longint;
begin
{ we don't need to allocate space for the locals }
aktprocdef.localst.datasize:=0;
procinfo.firsttemp_offset:=0;
{ replace framepointer with stackpointer }
procinfo^.framepointer:=STACK_POINTER_REG;
procinfo.framepointer.enum:=R_INTREGISTER;
procinfo.framepointer.number:=NR_STACK_POINTER_REG;
{ set the right value for parameters }
dec(aktprocdef.parast.address_fixup,pointer_size);
dec(procinfo^.para_offset,pointer_size);
dec(procinfo.para_offset,pointer_size);
{ replace all references to parameters in the instructions,
the parameters can be identified by the parafixup option
that is set. For normal user coded [ebp+4] this field is not
@ -1106,7 +1040,8 @@ implementation
ref_parafixup :
begin
ref^.offsetfixup:=parafixup;
ref^.base:=STACK_POINTER_REG;
ref^.base.enum:=R_INTREGISTER;
ref^.base.number:=NR_STACK_POINTER_REG;
end;
end;
end;
@ -1138,57 +1073,34 @@ implementation
var
p : tnode;
haslocals,hasparas : boolean;
begin
{ retrieve info about locals and paras before a result
is inserted in the symtable }
haslocals:=(aktprocdef.localst.datasize>0);
hasparas:=(aktprocdef.parast.datasize>0);
{ temporary space is set, while the BEGIN of the procedure }
if symtablestack.symtabletype=localsymtable then
procinfo^.firsttemp_offset := -symtablestack.datasize
else
procinfo^.firsttemp_offset := 0;
{ assembler code does not allocate }
{ space for the return value }
{ Rename the funcret so that recursive calls are possible }
if not is_void(aktprocdef.rettype.def) then
begin
aktprocdef.funcretsym:=tfuncretsym.create(aktprocsym.name,aktprocdef.rettype);
{ insert in local symtable }
{ but with another name, so that recursive calls are possible }
symtablestack.insert(aktprocdef.funcretsym);
symtablestack.rename(aktprocdef.funcretsym.name,'$result');
{ update the symtablesize back to 0 if there were no locals }
if not haslocals then
symtablestack.datasize:=0;
{ set the used flag for the return }
if ret_in_acc(aktprocdef.rettype.def) then
include(rg.usedinproc,accumulator);
end;
symtablestack.rename(aktprocdef.funcretsym.name,'$result');
{ force the asm statement }
if token<>_ASM then
consume(_ASM);
procinfo^.Flags := procinfo^.Flags Or pi_is_assembler;
procinfo.Flags := procinfo.Flags Or pi_is_assembler;
p:=_asm_statement;
{ set the framepointer to esp for assembler functions when the
following conditions are met:
- if the are no local variables
- if the are no local variables (except the allocated result)
- if the are no parameters
- no reference to the result variable (refcount<=1)
- result is not stored as parameter
- target processor has optional frame pointer save
(vm, i386, vm only currently)
}
if (po_assembler in aktprocdef.procoptions) and
(not haslocals) and
(not hasparas) and
(aktprocdef.parast.datasize=0) and
(aktprocdef.localst.datasize=aktprocdef.rettype.def.size) and
(aktprocdef.owner.symtabletype<>objectsymtable) and
(not assigned(aktprocdef.funcretsym) or
(tfuncretsym(aktprocdef.funcretsym).refcount<=1)) and
not(ret_in_param(aktprocdef.rettype.def)) and
not(paramanager.ret_in_param(aktprocdef.rettype.def,aktprocdef.proccalloption)) and
(target_cpu in [cpu_i386,cpu_m68k,cpu_vm])
{$ifdef CHECKFORPUSH}
and not(UsesPush(tasmnode(p)))
@ -1196,11 +1108,11 @@ implementation
then
OptimizeFramePointer(tasmnode(p));
{ Flag the result as assigned when it is returned in the
accumulator or on the fpu stack }
{ Flag the result as assigned when it is returned in a
register.
}
if assigned(aktprocdef.funcretsym) and
(is_fpu(aktprocdef.rettype.def) or
ret_in_acc(aktprocdef.rettype.def)) then
paramanager.ret_in_reg(aktprocdef.rettype.def,aktprocdef.proccalloption) then
tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
{ because the END is already read we need to get the
@ -1213,219 +1125,158 @@ implementation
end.
{
$Log$
Revision 1.54 2002-04-21 19:02:05 peter
* removed newn and disposen nodes, the code is now directly
inlined from pexpr
* -an option that will write the secondpass nodes to the .s file, this
requires EXTDEBUG define to actually write the info
* fixed various internal errors and crashes due recent code changes
Revision 1.90 2002-04-25 20:15:40 florian
* block nodes within expressions shouldn't release the used registers,
fixed using a flag till the new rg is ready
Revision 1.53 2002/04/20 21:32:24 carl
+ generic FPC_CHECKPOINTER
+ first parameter offset in stack now portable
* rename some constants
+ move some cpu stuff to other units
- remove unused constents
* fix stacksize for some targets
* fix generic size problems which depend now on EXTEND_SIZE constant
Revision 1.89 2003/04/25 08:25:26 daniel
* Ifdefs around a lot of calls to cleartempgen
* Fixed registers that are allocated but not freed in several nodes
* Tweak to register allocator to cause less spills
* 8-bit registers now interfere with esi,edi and ebp
Compiler can now compile rtl successfully when using new register
allocator
Revision 1.52 2002/04/16 16:11:17 peter
* using inherited; without a parent having the same function
will do nothing like delphi
Revision 1.88 2003/03/28 19:16:57 peter
* generic constructor working for i386
* remove fixed self register
* esi added as address register for i386
Revision 1.51 2002/04/15 19:01:28 carl
+ target_info.size_of_pointer -> pointer_Size
Revision 1.87 2003/03/17 18:55:30 peter
* allow more tokens instead of only semicolon after inherited
Revision 1.50 2002/04/14 16:53:54 carl
+ asm statement uses ALL_REGISTERS
Revision 1.86 2003/02/19 22:00:14 daniel
* Code generator converted to new register notation
- Horribily outdated todo.txt removed
Revision 1.49 2002/03/31 20:26:36 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)
* temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
* some small improvements and fixes to the optimizer
* some register allocation fixes
* some fpuvaroffset fixes in the unary minus node
* push/popusedregisters is now called rg.save/restoreusedregisters and
(for i386) uses temps instead of push/pop's when using -Op3 (that code is
also better optimizable)
* fixed and optimized register saving/restoring for new/dispose nodes
* LOC_FPU locations now also require their "register" field to be set to
R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
- list field removed of the tnode class because it's not used currently
and can cause hard-to-find bugs
Revision 1.85 2003/01/08 18:43:56 daniel
* Tregister changed into a record
Revision 1.48 2002/03/11 19:10:28 peter
* Regenerated with updated fpcmake
Revision 1.84 2003/01/01 21:05:24 peter
* fixed assembler methods stackpointer optimization that was
broken after the previous change
Revision 1.47 2002/03/04 17:54:59 peter
* allow oridinal labels again
Revision 1.83 2002/12/29 18:59:34 peter
* fixed parsing of declarations before asm statement
Revision 1.46 2002/01/29 21:32:03 peter
* allow accessing locals in other lexlevel when the current assembler
routine doesn't have locals.
Revision 1.82 2002/12/27 18:18:56 peter
* check for else after empty raise statement
Revision 1.45 2002/01/24 18:25:49 peter
* implicit result variable generation for assembler routines
* removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
Revision 1.81 2002/11/27 02:37:14 peter
* case statement inlining added
* fixed inlining of write()
* switched statementnode left and right parts so the statements are
processed in the correct order when getcopy is used. This is
required for tempnodes
Revision 1.44 2001/11/09 10:06:56 jonas
* allow recursive calls again in assembler procedure
Revision 1.80 2002/11/25 17:43:22 peter
* splitted defbase in defutil,symutil,defcmp
* merged isconvertable and is_equal into compare_defs(_ext)
* made operator search faster by walking the list only once
Revision 1.43 2001/11/02 22:58:05 peter
* procsym definition rewrite
Revision 1.79 2002/11/18 17:31:58 peter
* pass proccalloption to ret_in_xxx and push_xxx functions
Revision 1.42 2001/10/26 22:36:42 florian
* fixed ranges in case statements with widechars
Revision 1.78 2002/09/07 19:34:08 florian
+ tcg.direction is used now
Revision 1.41 2001/10/25 21:22:37 peter
* calling convention rewrite
Revision 1.77 2002/09/07 15:25:07 peter
* old logs removed and tabs fixed
Revision 1.40 2001/10/24 11:51:39 marco
* Make new/dispose system functions instead of keywords
Revision 1.76 2002/09/07 12:16:03 carl
* second part bug report 1996 fix, testrange in cordconstnode
only called if option is set (also make parsing a tiny faster)
Revision 1.39 2001/10/17 22:41:04 florian
* several widechar fixes, case works now
Revision 1.75 2002/09/02 18:40:52 peter
* fixed parsing of register names with lowercase
Revision 1.38 2001/10/16 15:10:35 jonas
* fixed goto/label/try bugs
Revision 1.74 2002/09/01 14:43:12 peter
* fixed direct assembler for i386
Revision 1.37 2001/09/22 11:11:43 peter
* "fpc -P?" command to query for used ppcXXX compiler
Revision 1.73 2002/08/25 19:25:20 peter
* sym.insert_in_data removed
* symtable.insertvardata/insertconstdata added
* removed insert_in_data call from symtable.insert, it needs to be
called separatly. This allows to deref the address calculation
* procedures now calculate the parast addresses after the procedure
directives are parsed. This fixes the cdecl parast problem
* push_addr_param has an extra argument that specifies if cdecl is used
or not
Revision 1.36 2001/09/06 10:21:50 jonas
* fixed superfluous generation of stackframes for assembler procedures
with no local vars or para's (this broke the backtrace printing in case
of an rte)
Revision 1.72 2002/08/17 09:23:40 florian
* first part of procinfo rewrite
Revision 1.35 2001/09/03 13:19:12 jonas
* set funcretsym for assembler procedures too (otherwise using __RESULT
in assembler procedures causes a crash)
Revision 1.71 2002/08/16 14:24:58 carl
* issameref() to test if two references are the same (then emit no opcodes)
+ ret_in_reg to replace ret_in_acc
(fix some register allocation bugs at the same time)
+ save_std_register now has an extra parameter which is the
usedinproc registers
Revision 1.34 2001/08/26 13:36:46 florian
* some cg reorganisation
* some PPC updates
Revision 1.70 2002/08/11 14:32:27 peter
* renamed current_library to objectlibrary
Revision 1.33 2001/08/23 14:28:36 jonas
+ tempcreate/ref/delete nodes (allows the use of temps in the
resulttype and first pass)
* made handling of read(ln)/write(ln) processor independent
* moved processor independent handling for str and reset/rewrite-typed
from firstpass to resulttype pass
* changed names of helpers in text.inc to be generic for use as
compilerprocs + added "iocheck" directive for most of them
* reading of ordinals is done by procedures instead of functions
because otherwise FPC_IOCHECK overwrote the result before it could
be stored elsewhere (range checking still works)
* compilerprocs can now be used in the system unit before they are
implemented
* added note to errore.msg that booleans can't be read using read/readln
Revision 1.69 2002/08/11 13:24:12 peter
* saving of asmsymbols in ppu supported
* asmsymbollist global is removed and moved into a new class
tasmlibrarydata that will hold the info of a .a file which
corresponds with a single module. Added librarydata to tmodule
to keep the library info stored for the module. In the future the
objectfiles will also be stored to the tasmlibrarydata class
* all getlabel/newasmsymbol and friends are moved to the new class
Revision 1.32 2001/08/06 21:40:47 peter
* funcret moved from tprocinfo to tprocdef
Revision 1.68 2002/08/10 14:46:30 carl
+ moved target_cpu_string to cpuinfo
* renamed asmmode enum.
* assembler reader has now less ifdef's
* move from nppcmem.pas -> ncgmem.pas vec. node.
Revision 1.31 2001/06/03 21:57:37 peter
+ hint directive parsing support
Revision 1.67 2002/08/09 19:11:44 carl
+ reading of used registers in assembler routines is now
cpu-independent
Revision 1.30 2001/05/17 13:25:24 jonas
* fixed web bugs 1480 and 1481
Revision 1.66 2002/08/06 20:55:22 florian
* first part of ppc calling conventions fix
Revision 1.29 2001/05/04 15:52:04 florian
* some Delphi incompatibilities fixed:
- out, dispose and new can be used as idenfiers now
- const p = apointerype(nil); is supported now
+ support for const p = apointertype(pointer(1234)); added
Revision 1.65 2002/07/28 20:45:22 florian
+ added direct assembler reader for PowerPC
Revision 1.28 2001/04/21 12:03:11 peter
* m68k updates merged from fixes branch
Revision 1.64 2002/07/20 11:57:56 florian
* types.pas renamed to defbase.pas because D6 contains a types
unit so this would conflicts if D6 programms are compiled
+ Willamette/SSE2 instructions to assembler added
Revision 1.27 2001/04/18 22:01:57 peter
* registration of targets and assemblers
Revision 1.63 2002/07/19 11:41:36 daniel
* State tracker work
* The whilen and repeatn are now completely unified into whilerepeatn. This
allows the state tracker to change while nodes automatically into
repeat nodes.
* Resulttypepass improvements to the notn. 'not not a' is optimized away and
'not(a>b)' is optimized into 'a<=b'.
* Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
by removing the notn and later switchting the true and falselabels. The
same is done with 'repeat until not a'.
Revision 1.26 2001/04/15 09:48:30 peter
* fixed crash in labelnode
* easier detection of goto and label in try blocks
Revision 1.62 2002/07/16 15:34:20 florian
* exit is now a syssym instead of a keyword
Revision 1.25 2001/04/14 14:07:11 peter
* moved more code from pass_1 to det_resulttype
Revision 1.61 2002/07/11 14:41:28 florian
* start of the new generic parameter handling
Revision 1.24 2001/04/13 01:22:13 peter
* symtable change to classes
* range check generation and errors fixed, make cycle DEBUG=1 works
* memory leaks fixed
Revision 1.60 2002/07/04 20:43:01 florian
* first x86-64 patches
Revision 1.23 2001/04/04 22:43:52 peter
* remove unnecessary calls to firstpass
Revision 1.59 2002/07/01 18:46:25 peter
* internal linker
* reorganized aasm layer
Revision 1.22 2001/04/02 21:20:34 peter
* resulttype rewrite
Revision 1.58 2002/05/18 13:34:13 peter
* readded missing revisions
Revision 1.21 2001/03/22 22:35:42 florian
+ support for type a = (a=1); in Delphi mode added
+ procedure p(); in Delphi mode supported
+ on isn't keyword anymore, it can be used as
id etc. now
Revision 1.20 2001/03/11 22:58:50 peter
* getsym redesign, removed the globals srsym,srsymtable
Revision 1.19 2000/12/25 00:07:27 peter
+ new tlinkedlist class (merge of old tstringqueue,tcontainer and
tlinkedlist objects)
Revision 1.18 2000/12/23 19:59:35 peter
* object to class for ow/og objects
* split objectdata from objectoutput
Revision 1.17 2000/12/16 22:45:55 jonas
* fixed case statements with int64 values
Revision 1.16 2000/11/29 00:30:37 florian
* unused units removed from uses clause
* some changes for widestrings
Revision 1.15 2000/11/27 15:47:19 jonas
* fix for web bug 1251 (example 1)
Revision 1.14 2000/11/22 22:43:34 peter
* fixed crash with exception without sysutils (merged)
Revision 1.13 2000/11/04 14:25:21 florian
+ merged Attila's changes for interfaces, not tested yet
Revision 1.12 2000/10/31 22:02:50 peter
* symtable splitted, no real code changes
Revision 1.11 2000/10/14 21:52:56 peter
* fixed memory leaks
Revision 1.10 2000/10/14 10:14:52 peter
* moehrendorf oct 2000 rewrite
Revision 1.9 2000/10/01 19:48:25 peter
* lot of compile updates for cg11
Revision 1.8 2000/09/24 21:19:50 peter
* delphi compile fixes
Revision 1.7 2000/09/24 15:06:24 peter
* use defines.inc
Revision 1.6 2000/08/27 16:11:52 peter
* moved some util functions from globals,cobjects to cutils
* splitted files into finput,fmodule
Revision 1.5 2000/08/12 15:41:15 peter
* fixed bug 1096 (merged)
Revision 1.4 2000/08/12 06:46:06 florian
+ case statement for int64/qword implemented
Revision 1.3 2000/07/13 12:08:27 michael
+ patched to 1.1.0 with former 1.09patch from peter
Revision 1.2 2000/07/13 11:32:45 michael
+ removed logs
Revision 1.57 2002/05/16 19:46:44 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
}

15
compiler/x86/cpubase.pas
View File

@ -146,6 +146,15 @@ uses
RS_R13 = $0e; {R13}
RS_R14 = $0f; {R14}
RS_R15 = $10; {R15}
{ create aliases to allow code sharing between x86-64 and i386 }
RS_EAX = RS_RAX;
RS_EBX = RS_RBX;
RS_ECX = RS_RCX;
RS_EDX = RS_RDX;
RS_ESI = RS_RSI;
RS_EDI = RS_RDI;
RS_EBP = RS_RBP;
RS_ESP = RS_RSP;
{$else x86_64}
RS_SPECIAL = $00; {Special register}
RS_EAX = $01; {EAX}
@ -698,7 +707,11 @@ implementation
end.
{
$Log$
Revision 1.2 2002-04-25 16:12:09 florian
Revision 1.3 2002-04-25 20:15:40 florian
* block nodes within expressions shouldn't release the used registers,
fixed using a flag till the new rg is ready
Revision 1.2 2002/04/25 16:12:09 florian
* fixed more problems with cpubase and x86-64
Revision 1.1 2003/04/25 11:12:09 florian

449
compiler/x86_64/rgcpu.pas Normal file
View File

@ -0,0 +1,449 @@
{
$Id$
Copyright (c) 1998-2002 by Florian Klaempfl
This unit implements the i386 specific class for the register
allocator
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 rgcpu;
{$i fpcdefs.inc}
interface
uses
cpubase,
cpuinfo,
aasmbase,aasmtai,aasmcpu,
cclasses,globtype,cgbase,cginfo,rgobj;
type
trgcpu = class(trgobj)
{ to keep the same allocation order as with the old routines }
function getregisterint(list:Taasmoutput;size:Tcgsize):Tregister;override;
{$ifndef newra}
procedure ungetregisterint(list:Taasmoutput;r:Tregister); override;
function getexplicitregisterint(list:Taasmoutput;r:Tnewregister):Tregister;override;
{$endif newra}
function getregisterfpu(list: taasmoutput) : tregister; override;
procedure ungetregisterfpu(list: taasmoutput; r : tregister); override;
procedure ungetreference(list: taasmoutput; const ref : treference); override;
{# Returns a subset register of the register r with the specified size.
WARNING: There is no clearing of the upper parts of the register,
if a 8-bit / 16-bit register is converted to a 32-bit register.
It is up to the code generator to correctly zero fill the register
}
function makeregsize(reg: tregister; size: tcgsize): tregister; override;
procedure resetusableregisters;override;
{ corrects the fpu stack register by ofs }
function correct_fpuregister(r : tregister;ofs : byte) : tregister;
fpuvaroffset : byte;
end;
implementation
uses
systems,
globals,verbose,
tgobj;
{************************************************************************}
{ routine helpers }
{************************************************************************}
const
reg2reg64 : array[firstreg..lastreg] of toldregister = (R_NO,
R_RAX,R_RCX,R_RDX,R_RBX,R_RSP,R_RBP,R_RSI,R_RDI,
R_R8,R_R9,R_R10,R_R11,R_R12,R_R13,R_R14,R_R15,R_RIP,
R_RAX,R_RCX,R_RDX,R_RBX,R_RSP,R_RBP,R_RSI,R_RDI,
R_R8,R_R9,R_R10,R_R11,R_R12,R_R13,R_R14,R_R15,
R_RAX,R_RCX,R_RDX,R_RBX,R_RSP,R_RBP,R_RSI,R_RDI,
R_R8,R_R9,R_R10,R_R11,R_R12,R_R13,R_R14,R_R15,
R_RAX,R_RCX,R_RDX,R_RBX,R_RSP,R_RBP,R_RSI,R_RDI,
R_R8,R_R9,R_R10,R_R11,R_R12,R_R13,R_R14,R_R15,
R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO
);
reg2reg32 : array[firstreg..lastreg] of toldregister = (R_NO,
R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI,
R_R8D,R_R9D,R_R10D,R_R11D,R_R12D,R_R13D,R_R14D,R_R15D,R_NO,
R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI,
R_R8D,R_R9D,R_R10D,R_R11D,R_R12D,R_R13D,R_R14D,R_R15D,
R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI,
R_R8D,R_R9D,R_R10D,R_R11D,R_R12D,R_R13D,R_R14D,R_R15D,
R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI,
R_R8D,R_R9D,R_R10D,R_R11D,R_R12D,R_R13D,R_R14D,R_R15D,
R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO
);
reg2reg16 : array[firstreg..lastreg] of toldregister = (R_NO,
R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI,
R_R8W,R_R9W,R_R10W,R_R11W,R_R12W,R_R13W,R_R14W,R_R15W,R_NO,
R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI,
R_R8W,R_R9W,R_R10W,R_R11W,R_R12W,R_R13W,R_R14W,R_R15W,
R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI,
R_R8W,R_R9W,R_R10W,R_R11W,R_R12W,R_R13W,R_R14W,R_R15W,
R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI,
R_R8W,R_R9W,R_R10W,R_R11W,R_R12W,R_R13W,R_R14W,R_R15W,
R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO
);
reg2reg8 : array[firstreg..lastreg] of toldregister = (R_NO,
R_AL,R_CL,R_DL,R_BL,R_SPL,R_BPL,R_SIL,R_DIL,
R_R8B,R_R9B,R_R10B,R_R11B,R_R12B,R_R13B,R_R14B,R_R15B,R_NO,
R_AL,R_CL,R_DL,R_BL,R_SPL,R_BPL,R_SIL,R_DIL,
R_R8B,R_R9B,R_R10B,R_R11B,R_R12B,R_R13B,R_R14B,R_R15B,
R_AL,R_CL,R_DL,R_BL,R_SPL,R_BPL,R_SIL,R_DIL,
R_R8B,R_R9B,R_R10B,R_R11B,R_R12B,R_R13B,R_R14B,R_R15B,
R_AL,R_CL,R_DL,R_BL,R_SPL,R_BPL,R_SIL,R_DIL,
R_R8B,R_R9B,R_R10B,R_R11B,R_R12B,R_R13B,R_R14B,R_R15B,
R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,
R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO,R_NO
);
{ convert a register to a specfied register size }
function changeregsize(r:tregister;size:topsize):tregister;
var
reg : tregister;
begin
case size of
S_B :
reg.enum:=reg2reg8[r.enum];
S_W :
reg.enum:=reg2reg16[r.enum];
S_L :
reg.enum:=reg2reg32[r.enum];
S_Q :
reg.enum:=reg2reg64[r.enum];
else
internalerror(200204101);
end;
if reg.enum=R_NO then
internalerror(200204102);
changeregsize:=reg;
end;
{************************************************************************}
{ trgcpu }
{************************************************************************}
function trgcpu.getregisterint(list: taasmoutput;size:Tcgsize): tregister;
var subreg:Tsubregister;
begin
subreg:=cgsize2subreg(size);
if countunusedregsint=0 then
internalerror(10);
result.enum:=R_INTREGISTER;
{$ifdef TEMPREGDEBUG}
if curptree^.usableregsint-countunusedregsint>curptree^.registers32 then
internalerror(10);
{$endif TEMPREGDEBUG}
{$ifdef EXTTEMPREGDEBUG}
if curptree^.usableregs-countunusedregistersint>curptree^^.reallyusedregs then
curptree^.reallyusedregs:=curptree^^.usableregs-countunusedregistersint;
{$endif EXTTEMPREGDEBUG}
if RS_RAX in unusedregsint then
begin
dec(countunusedregsint);
exclude(unusedregsint,RS_RAX);
include(usedintinproc,RS_RAX);
result.number:=RS_RAX shl 8 or subreg;
{$ifdef TEMPREGDEBUG}
reg_user[R_RAX]:=curptree^;
{$endif TEMPREGDEBUG}
exprasmlist.concat(tai_regalloc.alloc(result));
end
else if RS_RDX in unusedregsint then
begin
dec(countunusedregsint);
exclude(unusedregsint,RS_RDX);
include(usedintinproc,RS_RDX);
result.number:=RS_RDX shl 8 or subreg;
{$ifdef TEMPREGDEBUG}
reg_user[R_RDX]:=curptree^;
{$endif TEMPREGDEBUG}
exprasmlist.concat(tai_regalloc.alloc(result));
end
else if RS_RBX in unusedregsint then
begin
dec(countunusedregsint);
exclude(unusedregsint,RS_RBX);
include(usedintinproc,RS_RBX);
result.number:=RS_RBX shl 8 or subreg;
{$ifdef TEMPREGDEBUG}
reg_user[R_RBX]:=curptree^;
{$endif TEMPREGDEBUG}
exprasmlist.concat(tai_regalloc.alloc(result));
end
else if RS_RCX in unusedregsint then
begin
dec(countunusedregsint);
exclude(unusedregsint,RS_RCX);
include(usedintinproc,RS_RCX);
result.number:=RS_RCX shl 8 or subreg;
{$ifdef TEMPREGDEBUG}
reg_user[R_RCX]:=curptree^;
{$endif TEMPREGDEBUG}
exprasmlist.concat(tai_regalloc.alloc(result));
end
else
internalerror(10);
{$ifdef TEMPREGDEBUG}
testregisters;
{$endif TEMPREGDEBUG}
end;
procedure trgcpu.ungetregisterint(list: taasmoutput; r : tregister);
var supreg:Tsuperregister;
begin
if r.enum=R_NO then
exit;
if r.enum<>R_INTREGISTER then
internalerror(200301234);
supreg:=r.number shr 8;
if (supreg in [RS_RDI]) then
begin
list.concat(tai_regalloc.DeAlloc(r));
exit;
end;
if not(supreg in [RS_RAX,RS_RBX,RS_RCX,RS_RDX,RS_RSI]) then
exit;
inherited ungetregisterint(list,r);
end;
function trgcpu.getexplicitregisterint(list: taasmoutput; r : tnewregister) : tregister;
var r2:Tregister;
begin
if (r shr 8) in [RS_RDI] then
begin
r2.enum:=R_INTREGISTER;
r2.number:=r;
list.concat(Tai_regalloc.alloc(r2));
getexplicitregisterint:=r2;
exit;
end;
result:=inherited getexplicitregisterint(list,r);
end;
function trgcpu.getregisterfpu(list: taasmoutput) : tregister;
begin
{ note: don't return R_ST0, see comments above implementation of }
{ a_loadfpu_* methods in cgcpu (JM) }
result.enum := R_ST;
end;
procedure trgcpu.ungetregisterfpu(list : taasmoutput; r : tregister);
begin
{ nothing to do, fpu stack management is handled by the load/ }
{ store operations in cgcpu (JM) }
end;
procedure trgcpu.ungetreference(list: taasmoutput; const ref : treference);
begin
ungetregisterint(list,ref.base);
ungetregisterint(list,ref.index);
end;
procedure trgcpu.resetusableregisters;
begin
inherited resetusableregisters;
fpuvaroffset := 0;
end;
function trgcpu.correct_fpuregister(r : tregister;ofs : byte) : tregister;
begin
correct_fpuregister.enum:=toldregister(longint(r.enum)+ofs);
end;
function trgcpu.makeregsize(reg: tregister; size: tcgsize): tregister;
var
_result : topsize;
begin
case size of
OS_32,OS_S32:
begin
_result := S_L;
end;
OS_8,OS_S8:
begin
_result := S_B;
end;
OS_16,OS_S16:
begin
_result := S_W;
end;
else
internalerror(2001092312);
end;
makeregsize := changeregsize(reg,_result);
end;
initialization
rg := trgcpu.create(15);
end.
{
$Log$
Revision 1.4 2002-04-25 20:15:40 florian
* block nodes within expressions shouldn't release the used registers,
fixed using a flag till the new rg is ready
Revision 1.3 2003/01/05 13:36:54 florian
* x86-64 compiles
+ very basic support for float128 type (x86-64 only)
Revision 1.2 2002/07/25 22:55:34 florian
* several fixes, small test units can be compiled
Revision 1.1 2002/07/24 22:38:15 florian
+ initial release of x86-64 target code
Revision 1.8 2002/07/01 18:46:34 peter
* internal linker
* reorganized aasm layer
Revision 1.7 2002/05/16 19:46:52 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.6 2002/05/12 16:53:18 peter
* moved entry and exitcode to ncgutil and cgobj
* foreach gets extra argument for passing local data to the
iterator function
* -CR checks also class typecasts at runtime by changing them
into as
* fixed compiler to cycle with the -CR option
* fixed stabs with elf writer, finally the global variables can
be watched
* removed a lot of routines from cga unit and replaced them by
calls to cgobj
* u32bit-s32bit updates for and,or,xor nodes. When one element is
u32bit then the other is typecasted also to u32bit without giving
a rangecheck warning/error.
* fixed pascal calling method with reversing also the high tree in
the parast, detected by tcalcst3 test
Revision 1.5 2002/04/21 15:43:32 carl
* changeregsize -> rg.makeregsize
* changeregsize moved from cpubase to here
Revision 1.4 2002/04/15 19:44:22 peter
* fixed stackcheck that would be called recursively when a stack
error was found
* generic changeregsize(reg,size) for i386 register resizing
* removed some more routines from cga unit
* fixed returnvalue handling
* fixed default stacksize of linux and go32v2, 8kb was a bit small :-)
Revision 1.3 2002/04/04 19:06:13 peter
* removed unused units
* use tlocation.size in cg.a_*loc*() routines
Revision 1.2 2002/04/02 17:11:39 peter
* tlocation,treference update
* LOC_CONSTANT added for better constant handling
* secondadd splitted in multiple routines
* location_force_reg added for loading a location to a register
of a specified size
* secondassignment parses now first the right and then the left node
(this is compatible with Kylix). This saves a lot of push/pop especially
with string operations
* adapted some routines to use the new cg methods
Revision 1.1 2002/03/31 20:26:40 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)
* temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
* some small improvements and fixes to the optimizer
* some register allocation fixes
* some fpuvaroffset fixes in the unary minus node
* push/popusedregisters is now called rg.save/restoreusedregisters and
(for i386) uses temps instead of push/pop's when using -Op3 (that code is
also better optimizable)
* fixed and optimized register saving/restoring for new/dispose nodes
* LOC_FPU locations now also require their "register" field to be set to
R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
- list field removed of the tnode class because it's not used currently
and can cause hard-to-find bugs
}