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

* More fixes for cross unit inlining, all tnodes are now implemented

Browse Source 
* Moved pocall_internconst to po_internconst because it is not a
    calling type at all and it conflicted when inlining of these small
    functions was requested
This commit is contained in:
peter 2002-08-19 19:36:42 +00:00
parent c3af3cda9b
commit 91b49914f6
19 changed files with 884 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
compiler/aasmbase.pas
View File

@ -184,6 +184,7 @@ interface
function newasmsymboltype(const s : string;_bind:TAsmSymBind;_typ:TAsmsymtype) : tasmsymbol;
function getasmsymbol(const s : string) : tasmsymbol;
function renameasmsymbol(const sold, snew : string):tasmsymbol;
function newasmlabel(nr:longint;is_addr,is_data:boolean) : tasmlabel;
{# create a new assembler label }
procedure getlabel(var l : tasmlabel);
{ make l as a new label and flag is_addr }
@ -665,9 +666,9 @@ implementation
begin
if not assigned(asmsymbolidx) then
internalerror(200208072);
if longint(pointer(s))>=asmsymbolppuidx then
if (longint(pointer(s))<1) or (longint(pointer(s))>asmsymbolppuidx) then
internalerror(200208073);
s:=asmsymbolidx^[longint(pointer(s))];
s:=asmsymbolidx^[longint(pointer(s))-1];
end;
end;
@ -809,6 +810,21 @@ implementation
end;
function TAsmLibraryData.newasmlabel(nr:longint;is_addr,is_data:boolean) : tasmlabel;
var
hp : tasmlabel;
begin
if is_addr then
hp:=tasmlabel.createaddr(nr)
else if is_data then
hp:=tasmlabel.createdata(nr)
else
hp:=tasmlabel.create(nr);
symbolsearch.insert(hp);
newasmlabel:=hp;
end;
procedure TAsmLibraryData.getlabel(var l : tasmlabel);
begin
l:=tasmlabel.create(nextlabelnr);
@ -843,7 +859,13 @@ implementation
end.
{
$Log$
Revision 1.7 2002-08-18 20:06:23 peter
Revision 1.8 2002-08-19 19:36:42 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.7 2002/08/18 20:06:23 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu

20
compiler/aasmtai.pas
View File

@ -467,7 +467,7 @@ uses
internalerror(200208182);
if not assigned(aiclass[t]) then
internalerror(200208183);
writeln('taiload: ',taitypestr[t]);
//writeln('taiload: ',taitypestr[t]);
{ generate tai of the correct class }
ppuloadai:=aiclass[t].ppuload(t,ppufile);
end
@ -484,7 +484,7 @@ writeln('taiload: ',taitypestr[t]);
begin
{ type, read by ppuloadnode }
ppufile.putbyte(byte(n.typ));
writeln('taiwrite: ',taitypestr[n.typ]);
//writeln('taiwrite: ',taitypestr[n.typ]);
n.ppuwrite(ppufile);
end
else
@ -513,11 +513,6 @@ writeln('taiwrite: ',taitypestr[n.typ]);
procedure tai.ppuwrite(ppufile:tcompilerppufile);
begin
{ marker, read by tailoadnode }
ppufile.putbyte(pputaimarker);
{ type, read by tailoadnode }
ppufile.putbyte(byte(typ));
{ read by tai.ppuload }
ppufile.putposinfo(fileinfo);
end;
@ -1036,7 +1031,6 @@ writeln('taiwrite: ',taitypestr[n.typ]);
begin
inherited ppuload(t,ppufile);
l:=tasmlabel(ppufile.getasmsymbol);
l.is_set:=true;
is_global:=boolean(ppufile.getbyte);
end;
@ -1052,6 +1046,7 @@ writeln('taiwrite: ',taitypestr[n.typ]);
procedure tai_label.derefimpl;
begin
objectlibrary.DerefAsmsymbol(l);
l.is_set:=true;
end;
@ -1467,6 +1462,7 @@ writeln('taiwrite: ',taitypestr[n.typ]);
{$ifdef i386}
ppufile.putbyte(byte(segprefix));
{$endif i386}
ppufile.putbyte(byte(is_jmp));
end;
@ -1552,7 +1548,13 @@ writeln('taiwrite: ',taitypestr[n.typ]);
end.
{
$Log$
Revision 1.7 2002-08-18 20:06:23 peter
Revision 1.8 2002-08-19 19:36:42 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.7 2002/08/18 20:06:23 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu

58
compiler/fppu.pas
View File

@ -461,7 +461,7 @@ uses
procedure tppumodule.putasmsymbol_in_idx(s:tnamedindexitem;arg:pointer);
begin
if tasmsymbol(s).ppuidx<>-1 then
librarydata.asmsymbolidx^[tasmsymbol(s).ppuidx]:=tasmsymbol(s);
librarydata.asmsymbolidx^[tasmsymbol(s).ppuidx-1]:=tasmsymbol(s);
end;
@ -469,9 +469,11 @@ uses
var
s : tasmsymbol;
i : longint;
asmsymtype : byte;
begin
{ get an ordered list of all symbols to put in the ppu }
getmem(librarydata.asmsymbolidx,librarydata.asmsymbolppuidx*sizeof(pointer));
fillchar(librarydata.asmsymbolidx^,librarydata.asmsymbolppuidx*sizeof(pointer),0);
librarydata.symbolsearch.foreach({$ifdef FPCPROCVAR}@{$endif}putasmsymbol_in_idx,nil);
{ write the number of symbols }
ppufile.putlongint(librarydata.asmsymbolppuidx);
@ -481,7 +483,23 @@ uses
s:=librarydata.asmsymbolidx^[i-1];
if not assigned(s) then
internalerror(200208071);
ppufile.putstring(s.name);
asmsymtype:=1;
if s.Classtype=tasmlabel then
begin
if tasmlabel(s).is_addr then
asmsymtype:=4
else if tasmlabel(s).typ=AT_DATA then
asmsymtype:=3
else
asmsymtype:=2;
end;
ppufile.putbyte(asmsymtype);
case asmsymtype of
1 :
ppufile.putstring(s.name);
2 :
ppufile.putlongint(tasmlabel(s).labelnr);
end;
ppufile.putbyte(byte(s.defbind));
ppufile.putbyte(byte(s.typ));
end;
@ -670,21 +688,41 @@ uses
procedure tppumodule.readasmsymbols;
var
labelnr,
i : longint;
name : string;
bind : TAsmSymBind;
typ : TAsmSymType;
asmsymtype : byte;
begin
librarydata.asmsymbolppuidx:=ppufile.getlongint;
if librarydata.asmsymbolppuidx>0 then
begin
getmem(librarydata.asmsymbolidx,librarydata.asmsymbolppuidx*sizeof(pointer));
fillchar(librarydata.asmsymbolidx^,librarydata.asmsymbolppuidx*sizeof(pointer),0);
for i:=1 to librarydata.asmsymbolppuidx do
begin
name:=ppufile.getstring;
asmsymtype:=ppufile.getbyte;
case asmsymtype of
1 :
name:=ppufile.getstring;
2..4 :
labelnr:=ppufile.getlongint;
else
internalerror(200208192);
end;
bind:=tasmsymbind(ppufile.getbyte);
typ:=tasmsymtype(ppufile.getbyte);
librarydata.asmsymbolidx^[i-1]:=librarydata.newasmsymboltype(name,bind,typ);
case asmsymtype of
1 :
librarydata.asmsymbolidx^[i-1]:=librarydata.newasmsymboltype(name,bind,typ);
2 :
librarydata.asmsymbolidx^[i-1]:=librarydata.newasmlabel(labelnr,false,false);
3 :
librarydata.asmsymbolidx^[i-1]:=librarydata.newasmlabel(labelnr,true,false);
4 :
librarydata.asmsymbolidx^[i-1]:=librarydata.newasmlabel(labelnr,false,true);
end;
end;
end;
end;
@ -740,6 +778,7 @@ uses
procedure tppumodule.load_implementation;
var
b : byte;
oldobjectlibrary : tasmlibrarydata;
begin
{ read implementation part }
repeat
@ -755,9 +794,12 @@ uses
until false;
{ we can now derefence all pointers to the implementation parts }
oldobjectlibrary:=objectlibrary;
objectlibrary:=librarydata;
tstoredsymtable(globalsymtable).derefimpl;
if assigned(localsymtable) then
tstoredsymtable(localsymtable).derefimpl;
objectlibrary:=oldobjectlibrary;
end;
@ -1275,7 +1317,13 @@ uses
end.
{
$Log$
Revision 1.22 2002-08-18 19:58:28 peter
Revision 1.23 2002-08-19 19:36:42 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.22 2002/08/18 19:58:28 peter
* more current_scanner fixes
Revision 1.21 2002/08/15 15:09:41 carl

9
compiler/globals.pas
View File

@ -1169,7 +1169,6 @@ implementation
'FAR16',
'FPCCALL',
'INLINE',
'', { internconst }
'', { internproc }
'', { palmossyscall }
'PASCAL',
@ -1480,7 +1479,13 @@ begin
end.
{
$Log$
Revision 1.64 2002-08-12 15:08:39 carl
Revision 1.65 2002-08-19 19:36:42 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.64 2002/08/12 15:08:39 carl
+ stab register indexes for powerpc (moved from gdb to cpubase)
+ tprocessor enumeration moved to cpuinfo
+ linker in target_info is now a class

10
compiler/globtype.pas
View File

@ -134,7 +134,6 @@ interface
pocall_far16, { Far16 for OS/2 }
pocall_fpccall, { FPC default calling }
pocall_inline, { Procedure is an assembler macro }
pocall_internconst, { procedure has constant evaluator intern }
pocall_internproc, { Procedure has compiler magic}
pocall_palmossyscall, { procedure is a PalmOS system call }
pocall_pascal, { pascal standard left to right }
@ -153,7 +152,6 @@ interface
'Far16',
'FPCCall',
'Inline',
'InternConst',
'InternProc',
'PalmOSSysCall',
'Pascal',
@ -209,7 +207,13 @@ implementation
end.
{
$Log$
Revision 1.30 2002-08-12 15:08:39 carl
Revision 1.31 2002-08-19 19:36:42 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.30 2002/08/12 15:08:39 carl
+ stab register indexes for powerpc (moved from gdb to cpubase)
+ tprocessor enumeration moved to cpuinfo
+ linker in target_info is now a class

167
compiler/ncal.pas
View File

@ -32,7 +32,7 @@ interface
{$ifdef state_tracking}
nstate,
{$endif state_tracking}
symbase,symtype,symsym,symdef,symtable;
symbase,symtype,symppu,symsym,symdef,symtable;
type
tcallnode = class(tbinarynode)
@ -62,6 +62,9 @@ interface
constructor createinternres(const name: string; params: tnode; const res: ttype);
constructor createinternreturn(const name: string; params: tnode; returnnode : tnode);
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
function pass_1 : tnode;override;
@ -89,6 +92,9 @@ interface
{ constructor }
constructor create(expr,next : tnode);virtual;
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
procedure gen_high_tree(openstring:boolean);
@ -107,9 +113,13 @@ interface
inlinetree : tnode;
inlineprocdef : tprocdef;
retoffset,para_offset,para_size : longint;
constructor create(callp,code : tnode);virtual;
constructor create(p:tprocdef);virtual;
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function getcopy : tnode;override;
function det_resulttype : tnode;override;
procedure insertintolist(l : tnodelist);override;
function pass_1 : tnode;override;
function docompare(p: tnode): boolean; override;
@ -240,6 +250,31 @@ implementation
inherited destroy;
end;
constructor tcallparanode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
ppufile.getsmallset(callparaflags);
hightree:=ppuloadnode(ppufile);
end;
procedure tcallparanode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putsmallset(callparaflags);
ppuwritenode(ppufile,hightree);
end;
procedure tcallparanode.derefimpl;
begin
inherited derefimpl;
if assigned(hightree) then
hightree.derefimpl;
end;
function tcallparanode.getcopy : tnode;
var
@ -704,6 +739,43 @@ implementation
end;
constructor tcallnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
symtableprocentry:=tprocsym(ppufile.getderef);
{$warning FIXME: No withsymtable support}
symtableproc:=nil;
procdefinition:=tprocdef(ppufile.getderef);
restypeset:=boolean(ppufile.getbyte);
methodpointer:=ppuloadnode(ppufile);
funcretrefnode:=ppuloadnode(ppufile);
end;
procedure tcallnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(symtableprocentry);
ppufile.putderef(procdefinition);
ppufile.putbyte(byte(restypeset));
ppuwritenode(ppufile,methodpointer);
ppuwritenode(ppufile,funcretrefnode);
end;
procedure tcallnode.derefimpl;
begin
inherited derefimpl;
resolvesym(pointer(symtableprocentry));
symtableproc:=symtableprocentry.owner;
resolvedef(pointer(procdefinition));
if assigned(methodpointer) then
methodpointer.derefimpl;
if assigned(funcretrefnode) then
funcretrefnode.derefimpl;
end;
procedure tcallnode.set_procvar(procvar:tnode);
begin
right:=procvar;
@ -1470,7 +1542,7 @@ implementation
end;
{ handle predefined procedures }
is_const:=(procdefinition.proccalloption=pocall_internconst) and
is_const:=(po_internconst in procdefinition.procoptions) and
((block_type in [bt_const,bt_type]) or
(assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn])));
if (procdefinition.proccalloption=pocall_internproc) or is_const then
@ -1617,7 +1689,7 @@ implementation
if not assigned(right) then
begin
if assigned(tprocdef(procdefinition).code) then
inlinecode:=cprocinlinenode.create(self,tnode(tprocdef(procdefinition).code))
inlinecode:=cprocinlinenode.create(tprocdef(procdefinition))
else
CGMessage(cg_e_no_code_for_inline_stored);
if assigned(inlinecode) then
@ -1830,28 +1902,22 @@ implementation
TPROCINLINENODE
****************************************************************************}
constructor tprocinlinenode.create(callp,code : tnode);
constructor tprocinlinenode.create(p:tprocdef);
begin
inherited create(procinlinen);
inlineprocdef:=tcallnode(callp).symtableprocentry.defs^.def;
inlineprocdef:=p;
retoffset:=-POINTER_SIZE; { less dangerous as zero (PM) }
para_offset:=0;
para_size:=inlineprocdef.para_size(target_info.alignment.paraalign);
if paramanager.ret_in_param(inlineprocdef.rettype.def) then
inc(para_size,POINTER_SIZE);
{ copy args }
if assigned(code) then
inlinetree:=code.getcopy
else inlinetree := nil;
registers32:=code.registers32;
registersfpu:=code.registersfpu;
{$ifdef SUPPORT_MMX}
registersmmx:=code.registersmmx;
{$endif SUPPORT_MMX}
resulttype:=inlineprocdef.rettype;
para_size:=0;
{ copy inlinetree }
if assigned(p.code) then
inlinetree:=p.code.getcopy
else
inlinetree:=nil;
end;
destructor tprocinlinenode.destroy;
begin
if assigned(inlinetree) then
@ -1859,6 +1925,35 @@ implementation
inherited destroy;
end;
constructor tprocinlinenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
inlineprocdef:=tprocdef(ppufile.getderef);
inlinetree:=ppuloadnode(ppufile);
retoffset:=-POINTER_SIZE; { less dangerous as zero (PM) }
para_offset:=0;
para_size:=0;
end;
procedure tprocinlinenode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(inlineprocdef);
ppuwritenode(ppufile,inlinetree);
end;
procedure tprocinlinenode.derefimpl;
begin
inherited derefimpl;
if assigned(inlinetree) then
inlinetree.derefimpl;
resolvedef(pointer(inlineprocdef));
end;
function tprocinlinenode.getcopy : tnode;
var
@ -1866,11 +1961,11 @@ implementation
begin
n:=tprocinlinenode(inherited getcopy);
n.inlineprocdef:=inlineprocdef;
if assigned(inlinetree) then
n.inlinetree:=inlinetree.getcopy
else
n.inlinetree:=nil;
n.inlineprocdef:=inlineprocdef;
n.retoffset:=retoffset;
n.para_offset:=para_offset;
n.para_size:=para_size;
@ -1882,13 +1977,29 @@ implementation
begin
end;
function tprocinlinenode.det_resulttype : tnode;
begin
resulttype:=inlineprocdef.rettype;
{ retrieve info from inlineprocdef }
retoffset:=-POINTER_SIZE; { less dangerous as zero (PM) }
para_offset:=0;
para_size:=inlineprocdef.para_size(target_info.alignment.paraalign);
if paramanager.ret_in_param(inlineprocdef.rettype.def) then
inc(para_size,POINTER_SIZE);
result:=nil;
end;
function tprocinlinenode.pass_1 : tnode;
begin
firstpass(inlinetree);
registers32:=inlinetree.registers32;
registersfpu:=inlinetree.registersfpu;
{$ifdef SUPPORT_MMX}
registersmmx:=inlinetree.registersmmx;
{$endif SUPPORT_MMX}
result:=nil;
{ left contains the code in tree form }
{ but it has already been firstpassed }
{ so firstpass(left); does not seem required }
{ might be required later if we change the arg handling !! }
end;
function tprocinlinenode.docompare(p: tnode): boolean;
@ -1906,7 +2017,13 @@ begin
end.
{
$Log$
Revision 1.86 2002-08-17 22:09:44 florian
Revision 1.87 2002-08-19 19:36:42 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.86 2002/08/17 22:09:44 florian
* result type handling in tcgcal.pass_2 overhauled
* better tnode.dowrite
* some ppc stuff fixed

14
compiler/ncgcal.pas
View File

@ -1405,11 +1405,17 @@ implementation
inlineexitcode:=TAAsmoutput.Create;
ps:=para_size;
make_global:=false; { to avoid warning }
aktfilepos.line:=0;
aktfilepos.column:=0;
aktfilepos.fileindex:=0;
genentrycode(inlineentrycode,make_global,0,ps,nostackframe,true);
if po_assembler in aktprocdef.procoptions then
inlineentrycode.insert(Tai_marker.Create(asmblockstart));
exprasmList.concatlist(inlineentrycode);
secondpass(inlinetree);
aktfilepos.line:=0;
aktfilepos.column:=0;
aktfilepos.fileindex:=0;
genexitcode(inlineexitcode,0,false,true);
if po_assembler in aktprocdef.procoptions then
inlineexitcode.concat(Tai_marker.Create(asmblockend));
@ -1469,7 +1475,13 @@ begin
end.
{
$Log$
Revision 1.12 2002-08-18 20:06:23 peter
Revision 1.13 2002-08-19 19:36:42 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.12 2002/08/18 20:06:23 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu

10
compiler/ncgflw.pas
View File

@ -602,7 +602,7 @@ do_jmp:
begin
load_all_regvars(exprasmlist);
cg.a_jmp_always(exprasmlist,labelnr)
cg.a_jmp_always(exprasmlist,labsym.lab)
end;
@ -1225,7 +1225,13 @@ begin
end.
{
$Log$
Revision 1.36 2002-08-15 15:15:55 carl
Revision 1.37 2002-08-19 19:36:43 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.36 2002/08/15 15:15:55 carl
* jmpbuf size allocation for exceptions is now cpu specific (as it should)
* more generic nodes for maths
* several fixes for better m68k support

42
compiler/ncnv.pas
View File

@ -28,7 +28,7 @@ interface
uses
node,
symtype,defbase,
symtype,symppu,defbase,
nld;
type
@ -37,6 +37,9 @@ interface
convtype : tconverttype;
constructor create(node : tnode;const t : ttype);virtual;
constructor create_explicit(node : tnode;const t : ttype);
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;
@ -483,6 +486,29 @@ implementation
end;
constructor ttypeconvnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
ppufile.gettype(totype);
convtype:=tconverttype(ppufile.getbyte);
end;
procedure ttypeconvnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.puttype(totype);
ppufile.putbyte(byte(convtype));
end;
procedure ttypeconvnode.derefimpl;
begin
inherited derefimpl;
totype.resolve;
end;
function ttypeconvnode.getcopy : tnode;
var
@ -1357,13 +1383,13 @@ implementation
function ttypeconvnode.first_int_to_real: tnode;
var
fname: string[19];
typname : string[12];
typname : string[12];
begin
{ Get the type name }
{ Normally the typename should be one of the following:
single, double - carl
}
typname := lower(pbestrealtype^.def.gettypename);
}
typname := lower(pbestrealtype^.def.gettypename);
{ converting a 64bit integer to a float requires a helper }
if is_64bitint(left.resulttype.def) then
begin
@ -1939,7 +1965,13 @@ begin
end.
{
$Log$
Revision 1.70 2002-08-17 09:23:36 florian
Revision 1.71 2002-08-19 19:36:43 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.70 2002/08/17 09:23:36 florian
* first part of procinfo rewrite
Revision 1.69 2002/08/14 19:26:55 carl

347
compiler/nflw.pas
View File

@ -28,8 +28,9 @@ unit nflw;
interface
uses
node,aasmbase,aasmtai,aasmcpu,cpubase,
symbase,symdef,symsym;
node,cpubase,
aasmbase,aasmtai,aasmcpu,
symppu,symtype,symbase,symdef,symsym;
type
tloopnode = class(tbinarynode)
@ -37,6 +38,9 @@ interface
constructor create(tt : tnodetype;l,r,_t1,_t2 : tnode);virtual;
destructor destroy;override;
function getcopy : tnode;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
procedure insertintolist(l : tnodelist);override;
{$ifdef extdebug}
procedure _dowrite;override;
@ -49,7 +53,7 @@ interface
function det_resulttype:tnode;override;
function pass_1 : tnode;override;
{$ifdef state_tracking}
function track_state_pass(exec_known:boolean):boolean;override;
function track_state_pass(exec_known:boolean):boolean;override;
{$endif}
end;
twhilerepeatnodeclass = class of twhilerepeatnode;
@ -90,10 +94,12 @@ interface
tcontinuenodeclass = class of tcontinuenode;
tgotonode = class(tnode)
labelnr : tasmlabel;
labsym : tlabelsym;
exceptionblock : integer;
constructor create(p : tlabelsym);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function getcopy : tnode;override;
function det_resulttype:tnode;override;
function pass_1 : tnode;override;
@ -107,6 +113,9 @@ interface
exceptionblock : integer;
constructor createcase(p : tasmlabel;l:tnode);virtual;
constructor create(p : tlabelsym;l:tnode);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function getcopy : tnode;override;
function det_resulttype:tnode;override;
function pass_1 : tnode;override;
@ -117,6 +126,9 @@ interface
traisenode = class(tbinarynode)
frametree : tnode;
constructor create(l,taddr,tframe:tnode);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
function det_resulttype:tnode;override;
@ -144,6 +156,7 @@ interface
excepttype : tobjectdef;
constructor create(l,r:tnode);virtual;
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
function det_resulttype:tnode;override;
function pass_1 : tnode;override;
function getcopy : tnode;override;
@ -199,12 +212,12 @@ implementation
case t of
ifn:
p:=cifnode.create(l,r,n1);
whilerepeatn:
if back then
{Repeat until.}
p:=cwhilerepeatnode.create(l,r,n1,false,true)
else
{While do.}
whilerepeatn:
if back then
{Repeat until.}
p:=cwhilerepeatnode.create(l,r,n1,false,true)
else
{While do.}
p:=cwhilerepeatnode.create(l,r,n1,true,false);
forn:
p:=cfornode.create(l,r,n1,nil,back);
@ -233,6 +246,33 @@ implementation
inherited destroy;
end;
constructor tloopnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
t1:=ppuloadnode(ppufile);
t2:=ppuloadnode(ppufile);
end;
procedure tloopnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppuwritenode(ppufile,t1);
ppuwritenode(ppufile,t2);
end;
procedure tloopnode.derefimpl;
begin
inherited derefimpl;
if assigned(t1) then
t1.derefimpl;
if assigned(t2) then
t2.derefimpl;
end;
function tloopnode.getcopy : tnode;
var
@ -281,11 +321,11 @@ implementation
constructor Twhilerepeatnode.create(l,r,_t1:Tnode;tab,cn:boolean);
begin
inherited create(whilerepeatn,l,r,_t1,nil);
if tab then
include(flags,nf_testatbegin);
if cn then
include(flags,nf_checknegate);
inherited create(whilerepeatn,l,r,_t1,nil);
if tab then
include(flags,nf_testatbegin);
if cn then
include(flags,nf_checknegate);
end;
function twhilerepeatnode.det_resulttype:tnode;
@ -296,16 +336,16 @@ implementation
resulttype:=voidtype;
resulttypepass(left);
{A not node can be removed.}
if left.nodetype=notn then
begin
t:=Tunarynode(left);
left:=Tunarynode(left).left;
t.left:=nil;
t.destroy;
{Symdif operator, in case you are wondering:}
flags:=flags >< [nf_checknegate];
end;
{A not node can be removed.}
if left.nodetype=notn then
begin
t:=Tunarynode(left);
left:=Tunarynode(left).left;
t.left:=nil;
t.destroy;
{Symdif operator, in case you are wondering:}
flags:=flags >< [nf_checknegate];
end;
{ loop instruction }
if assigned(right) then
resulttypepass(right);
@ -366,88 +406,88 @@ implementation
function Twhilerepeatnode.track_state_pass(exec_known:boolean):boolean;
var condition:Tnode;
code:Tnode;
done:boolean;
value:boolean;
change:boolean;
firsttest:boolean;
factval:Tnode;
code:Tnode;
done:boolean;
value:boolean;
change:boolean;
firsttest:boolean;
factval:Tnode;
begin
track_state_pass:=false;
done:=false;
firsttest:=true;
{For repeat until statements, first do a pass through the code.}
if not(nf_testatbegin in flags) then
begin
code:=right.getcopy;
if code.track_state_pass(exec_known) then
track_state_pass:=true;
code.destroy;
end;
repeat
condition:=left.getcopy;
code:=right.getcopy;
change:=condition.track_state_pass(exec_known);
factval:=aktstate.find_fact(left);
if factval<>nil then
begin
condition.destroy;
condition:=factval.getcopy;
change:=true;
end;
if change then
begin
track_state_pass:=true;
{Force new resulttype pass.}
condition.resulttype.def:=nil;
do_resulttypepass(condition);
end;
if is_constboolnode(condition) then
begin
{Try to turn a while loop into a repeat loop.}
if firsttest then
exclude(flags,testatbegin);
value:=(Tordconstnode(condition).value<>0) xor checknegate;
if value then
begin
if code.track_state_pass(exec_known) then
track_state_pass:=true;
end
else
done:=true;
end
else
begin
{Remove any modified variables from the state.}
code.track_state_pass(false);
done:=true;
end;
code.destroy;
condition.destroy;
firsttest:=false;
until done;
{The loop condition is also known, for example:
while i<10 do
begin
...
end;
When the loop is done, we do know that i<10 = false.
}
condition:=left.getcopy;
track_state_pass:=false;
done:=false;
firsttest:=true;
{For repeat until statements, first do a pass through the code.}
if not(nf_testatbegin in flags) then
begin
code:=right.getcopy;
if code.track_state_pass(exec_known) then
track_state_pass:=true;
code.destroy;
end;
repeat
condition:=left.getcopy;
code:=right.getcopy;
change:=condition.track_state_pass(exec_known);
factval:=aktstate.find_fact(left);
if factval<>nil then
begin
condition.destroy;
condition:=factval.getcopy;
change:=true;
end;
if change then
begin
track_state_pass:=true;
{Force new resulttype pass.}
condition.resulttype.def:=nil;
do_resulttypepass(condition);
end;
if is_constboolnode(condition) then
begin
{Try to turn a while loop into a repeat loop.}
if firsttest then
exclude(flags,testatbegin);
value:=(Tordconstnode(condition).value<>0) xor checknegate;
if value then
begin
if code.track_state_pass(exec_known) then
track_state_pass:=true;
end
else
done:=true;
end
else
begin
{Remove any modified variables from the state.}
code.track_state_pass(false);
done:=true;
end;
code.destroy;
condition.destroy;
firsttest:=false;
until done;
{The loop condition is also known, for example:
while i<10 do
begin
...
end;
When the loop is done, we do know that i<10 = false.
}
condition:=left.getcopy;
if condition.track_state_pass(exec_known) then
begin
track_state_pass:=true;
{Force new resulttype pass.}
condition.resulttype.def:=nil;
do_resulttypepass(condition);
end;
if not is_constboolnode(condition) then
aktstate.store_fact(condition,
cordconstnode.create(byte(checknegate),booltype))
else
condition.destroy;
begin
track_state_pass:=true;
{Force new resulttype pass.}
condition.resulttype.def:=nil;
do_resulttypepass(condition);
end;
if not is_constboolnode(condition) then
aktstate.store_fact(condition,
cordconstnode.create(byte(checknegate),booltype))
else
condition.destroy;
end;
{$endif}
@ -579,7 +619,7 @@ implementation
inherited create(forn,l,r,_t1,_t2);
if back then
include(flags,nf_backward);
include(flags,nf_testatbegin);
include(flags,nf_testatbegin);
end;
@ -590,20 +630,20 @@ implementation
result:=nil;
resulttype:=voidtype;
if left.nodetype<>assignn then
begin
CGMessage(cg_e_illegal_expression);
exit;
end;
{Can we spare the first comparision?}
{Can we spare the first comparision?}
if (right.nodetype=ordconstn) and (Tassignmentnode(left).right.nodetype=ordconstn) then
if not(((nf_backward in flags) and
if not(((nf_backward in flags) and
(Tordconstnode(Tassignmentnode(left).right).value>=Tordconstnode(right).value))
or (not(nf_backward in flags) and
(Tordconstnode(Tassignmentnode(left).right).value<=Tordconstnode(right).value))) then
exclude(flags,nf_testatbegin);
exclude(flags,nf_testatbegin);
{ save counter var }
t2:=tassignmentnode(left).left.getcopy;
@ -829,7 +869,29 @@ implementation
inherited create(goton);
exceptionblock:=aktexceptblock;
labsym:=p;
labelnr:=p.lab;
end;
constructor tgotonode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
labsym:=tlabelsym(ppufile.getderef);
exceptionblock:=ppufile.getbyte;
end;
procedure tgotonode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(labsym);
ppufile.putbyte(exceptionblock);
end;
procedure tgotonode.derefimpl;
begin
inherited derefimpl;
resolvesym(pointer(labsym));
end;
@ -860,7 +922,6 @@ implementation
p : tgotonode;
begin
p:=tgotonode(inherited getcopy);
p.labelnr:=labelnr;
p.labsym:=labsym;
p.exceptionblock:=exceptionblock;
result:=p;
@ -898,6 +959,32 @@ implementation
end;
constructor tlabelnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
labsym:=tlabelsym(ppufile.getderef);
labelnr:=tasmlabel(ppufile.getasmsymbol);
exceptionblock:=ppufile.getbyte;
end;
procedure tlabelnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(labsym);
ppufile.putasmsymbol(labelnr);
ppufile.putbyte(exceptionblock);
end;
procedure tlabelnode.derefimpl;
begin
inherited derefimpl;
resolvesym(pointer(labsym));
objectlibrary.derefasmsymbol(labelnr);
end;
function tlabelnode.det_resulttype:tnode;
begin
result:=nil;
@ -953,6 +1040,28 @@ implementation
end;
constructor traisenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
frametree:=ppuloadnode(ppufile);
end;
procedure traisenode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppuwritenode(ppufile,frametree);
end;
procedure traisenode.derefimpl;
begin
inherited derefimpl;
if assigned(frametree) then
frametree.derefimpl;
end;
function traisenode.getcopy : tnode;
var
n : traisenode;
@ -1136,6 +1245,14 @@ implementation
end;
constructor tonnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
exceptsymtable:=nil;
excepttype:=nil;
end;
function tonnode.getcopy : tnode;
var
n : tonnode;
@ -1244,7 +1361,13 @@ begin
end.
{
$Log$
Revision 1.46 2002-08-17 22:09:46 florian
Revision 1.47 2002-08-19 19:36:43 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.46 2002/08/17 22:09:46 florian
* result type handling in tcgcal.pass_2 overhauled
* better tnode.dowrite
* some ppc stuff fixed

26
compiler/ninl.pas
View File

@ -27,7 +27,7 @@ unit ninl;
interface
uses
node,htypechk,cpuinfo;
node,htypechk,cpuinfo,symppu;
{$i compinnr.inc}
@ -35,6 +35,8 @@ interface
tinlinenode = class(tunarynode)
inlinenumber : byte;
constructor create(number : byte;is_const:boolean;l : tnode);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
function getcopy : tnode;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
@ -96,6 +98,20 @@ implementation
end;
constructor tinlinenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
inlinenumber:=ppufile.getbyte;
end;
procedure tinlinenode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putbyte(inlinenumber);
end;
function tinlinenode.getcopy : tnode;
var
n : tinlinenode;
@ -2346,7 +2362,13 @@ begin
end.
{
$Log$
Revision 1.83 2002-08-02 07:44:31 jonas
Revision 1.84 2002-08-19 19:36:43 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.83 2002/08/02 07:44:31 jonas
* made assigned() handling generic
* add nodes now can also evaluate constant expressions at compile time
that contain nil nodes

11
compiler/nld.pas
View File

@ -696,6 +696,7 @@ implementation
procedure tfuncretnode.derefimpl;
begin
inherited derefimpl;
resolvesym(pointer(funcretsym));
end;
@ -996,6 +997,7 @@ implementation
procedure ttypenode.derefimpl;
begin
inherited derefimpl;
restype.resolve;
end;
@ -1060,6 +1062,7 @@ implementation
procedure trttinode.derefimpl;
begin
inherited derefimpl;
resolvedef(pointer(rttidef));
end;
@ -1117,7 +1120,13 @@ begin
end.
{
$Log$
Revision 1.52 2002-08-18 20:06:23 peter
Revision 1.53 2002-08-19 19:36:43 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.52 2002/08/18 20:06:23 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu

136
compiler/nmem.pas
View File

@ -28,7 +28,7 @@ interface
uses
node,
symtype,symdef,symsym,symtable,
symtype,symppu,symdef,symsym,symtable,
cpubase;
type
@ -42,6 +42,9 @@ interface
thnewnode = class(tnode)
objtype : ttype;
constructor create(t:ttype);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
end;
@ -57,6 +60,10 @@ interface
taddrnode = class(tunarynode)
getprocvardef : tprocvardef;
constructor create(l : tnode);virtual;
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;
end;
@ -79,6 +86,9 @@ interface
tsubscriptnode = class(tunarynode)
vs : tvarsym;
constructor create(varsym : tsym;l : tnode);virtual;
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 docompare(p: tnode): boolean; override;
@ -96,6 +106,9 @@ interface
tselfnode = class(tnode)
classdef : tdef; { objectdef or classrefdef }
constructor create(_class : tdef);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
end;
@ -107,6 +120,8 @@ interface
withreference : treference;
constructor create(symtable : twithsymtable;l,r : tnode;count : longint);virtual;
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
function getcopy : tnode;override;
function pass_1 : tnode;override;
function docompare(p: tnode): boolean; override;
@ -173,6 +188,27 @@ implementation
end;
constructor thnewnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
ppufile.gettype(objtype);
end;
procedure thnewnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.puttype(objtype);
end;
procedure thnewnode.derefimpl;
begin
inherited derefimpl;
objtype.resolve;
end;
function thnewnode.det_resulttype:tnode;
begin
result:=nil;
@ -242,6 +278,40 @@ implementation
begin
inherited create(addrn,l);
getprocvardef:=nil;
end;
constructor taddrnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
getprocvardef:=tprocvardef(ppufile.getderef);
end;
procedure taddrnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(getprocvardef);
end;
procedure taddrnode.derefimpl;
begin
inherited derefimpl;
resolvedef(pointer(getprocvardef));
end;
function taddrnode.getcopy : tnode;
var
p : taddrnode;
begin
p:=taddrnode(inherited getcopy);
p.getprocvardef:=getprocvardef;
getcopy:=p;
end;
@ -528,6 +598,27 @@ implementation
vs:=tvarsym(varsym);
end;
constructor tsubscriptnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
vs:=tvarsym(ppufile.getderef);
end;
procedure tsubscriptnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(vs);
end;
procedure tsubscriptnode.derefimpl;
begin
inherited derefimpl;
resolvesym(pointer(vs));
end;
function tsubscriptnode.getcopy : tnode;
var
@ -755,6 +846,27 @@ implementation
classdef:=_class;
end;
constructor tselfnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
classdef:=tdef(ppufile.getderef);
end;
procedure tselfnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(classdef);
end;
procedure tselfnode.derefimpl;
begin
inherited derefimpl;
resolvedef(pointer(classdef));
end;
function tselfnode.det_resulttype:tnode;
begin
result:=nil;
@ -807,6 +919,20 @@ implementation
end;
constructor twithnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
internalerror(200208192);
end;
procedure twithnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
internalerror(200208193);
end;
function twithnode.getcopy : tnode;
var
@ -894,7 +1020,13 @@ begin
end.
{
$Log$
Revision 1.35 2002-07-23 09:51:23 daniel
Revision 1.36 2002-08-19 19:36:43 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.35 2002/07/23 09:51:23 daniel
* Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
are worth comitting.

12
compiler/node.pas
View File

@ -468,7 +468,7 @@ implementation
begin
if not assigned(nodeclass[t]) then
internalerror(200208153);
writeln('load: ',nodetype2str[t]);
//writeln('load: ',nodetype2str[t]);
{ generate node of the correct class }
ppuloadnode:=nodeclass[t].ppuload(t,ppufile);
end
@ -485,7 +485,7 @@ writeln('load: ',nodetype2str[t]);
if assigned(n) then
begin
ppufile.putbyte(byte(n.nodetype));
writeln('write: ',nodetype2str[n.nodetype]);
//writeln('write: ',nodetype2str[n.nodetype]);
n.ppuwrite(ppufile);
end
else
@ -972,7 +972,13 @@ writeln('write: ',nodetype2str[n.nodetype]);
end.
{
$Log$
Revision 1.37 2002-08-18 20:06:24 peter
Revision 1.38 2002-08-19 19:36:44 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.37 2002/08/18 20:06:24 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu

130
compiler/nset.pas
View File

@ -27,7 +27,9 @@ unit nset;
interface
uses
node,globals,aasmbase,aasmtai;
node,globals,
aasmbase,aasmtai,
symppu;
type
pcaserecord = ^tcaserecord;
@ -75,6 +77,9 @@ interface
elseblock : tnode;
constructor create(l,r : tnode;n : pcaserecord);virtual;
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
function det_resulttype:tnode;override;
@ -198,22 +203,22 @@ implementation
pes:=tenumsym(tenumdef(psd.elementtype.def).firstenum);
while assigned(pes) do
begin
{$ifdef oldset}
pcs^[pes.value div 8]:=pcs^[pes.value div 8] or (1 shl (pes.value mod 8));
{$else}
include(pcs^,pes.value);
{$endif}
{$ifdef oldset}
pcs^[pes.value div 8]:=pcs^[pes.value div 8] or (1 shl (pes.value mod 8));
{$else}
include(pcs^,pes.value);
{$endif}
pes:=pes.nextenum;
end;
end;
orddef :
begin
for i:=torddef(psd.elementtype.def).low to torddef(psd.elementtype.def).high do
{$ifdef oldset}
{$ifdef oldset}
pcs^[i div 8]:=pcs^[i div 8] or (1 shl (i mod 8));
{$else}
include(pcs^,i);
{$endif}
{$else}
include(pcs^,i);
{$endif}
end;
end;
createsetconst:=pcs;
@ -276,11 +281,11 @@ implementation
{ constant evaluation }
if (left.nodetype=ordconstn) and (right.nodetype=setconstn) then
begin
{$ifdef oldset}
t:=cordconstnode.create(byte(tordconstnode(left).value in byteset(tsetconstnode(right).value_set^)),booltype);
{$else}
{$ifdef oldset}
t:=cordconstnode.create(byte(tordconstnode(left).value in byteset(tsetconstnode(right).value_set^)),booltype);
{$else}
t:=cordconstnode.create(byte(tordconstnode(left).value in Tsetconstnode(right).value_set^),booltype);
{$endif}
{$endif}
resulttypepass(t);
result:=t;
exit;
@ -446,6 +451,65 @@ implementation
copycaserecord:=n;
end;
procedure ppuwritecaserecord(ppufile:tcompilerppufile;p : pcaserecord);
var
b : byte;
begin
ppufile.putexprint(p^._low);
ppufile.putexprint(p^._high);
ppufile.putasmsymbol(p^._at);
ppufile.putasmsymbol(p^.statement);
ppufile.putbyte(byte(p^.firstlabel));
b:=0;
if assigned(p^.greater) then
b:=b or 1;
if assigned(p^.less) then
b:=b or 2;
ppufile.putbyte(b);
if assigned(p^.greater) then
ppuwritecaserecord(ppufile,p^.greater);
if assigned(p^.less) then
ppuwritecaserecord(ppufile,p^.less);
end;
function ppuloadcaserecord(ppufile:tcompilerppufile):pcaserecord;
var
b : byte;
p : pcaserecord;
begin
new(p);
p^._low:=ppufile.getexprint;
p^._high:=ppufile.getexprint;
p^._at:=tasmlabel(ppufile.getasmsymbol);
p^.statement:=tasmlabel(ppufile.getasmsymbol);
p^.firstlabel:=boolean(ppufile.getbyte);
b:=ppufile.getbyte;
if (b and 1)=1 then
p^.greater:=ppuloadcaserecord(ppufile)
else
p^.greater:=nil;
if (b and 2)=2 then
p^.less:=ppuloadcaserecord(ppufile)
else
p^.less:=nil;
ppuloadcaserecord:=p;
end;
procedure ppuderefcaserecord(p : pcaserecord);
begin
objectlibrary.derefasmsymbol(p^._at);
objectlibrary.derefasmsymbol(p^.statement);
if assigned(p^.greater) then
ppuderefcaserecord(p^.greater);
if assigned(p^.less) then
ppuderefcaserecord(p^.less);
end;
{*****************************************************************************
TCASENODE
*****************************************************************************}
@ -467,6 +531,31 @@ implementation
end;
constructor tcasenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
elseblock:=ppuloadnode(ppufile);
nodes:=ppuloadcaserecord(ppufile);
end;
procedure tcasenode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppuwritenode(ppufile,elseblock);
ppuwritecaserecord(ppufile,nodes);
end;
procedure tcasenode.derefimpl;
begin
inherited derefimpl;
if assigned(elseblock) then
elseblock.derefimpl;
ppuderefcaserecord(nodes);
end;
function tcasenode.det_resulttype : tnode;
begin
result:=nil;
@ -559,7 +648,10 @@ implementation
p.elseblock:=elseblock.getcopy
else
p.elseblock:=nil;
p.nodes:=copycaserecord(nodes);
if assigned(nodes) then
p.nodes:=copycaserecord(nodes)
else
p.nodes:=nil;
getcopy:=p;
end;
@ -597,7 +689,13 @@ begin
end.
{
$Log$
Revision 1.31 2002-08-17 09:23:38 florian
Revision 1.32 2002-08-19 19:36:44 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.31 2002/08/17 09:23:38 florian
* first part of procinfo rewrite
Revision 1.30 2002/07/23 13:19:40 jonas

17
compiler/pass_2.pas
View File

@ -179,7 +179,14 @@ implementation
curptree:=@p;
p^.usableregs:=usablereg32;
{$endif TEMPREGDEBUG}
aktfilepos:=p.fileinfo;
if inlining_procedure then
begin
aktfilepos.line:=0;
aktfilepos.column:=0;
aktfilepos.fileindex:=0;
end
else
aktfilepos:=p.fileinfo;
aktlocalswitches:=p.localswitches;
codegenerror:=false;
{$ifdef EXTDEBUG}
@ -330,7 +337,13 @@ implementation
end.
{
$Log$
Revision 1.36 2002-08-18 20:06:24 peter
Revision 1.37 2002-08-19 19:36:44 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.36 2002/08/18 20:06:24 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu

20
compiler/pdecsub.pas
View File

@ -1114,8 +1114,8 @@ const
idtok:_INTERNCONST;
pd_flags : pd_implemen+pd_body+pd_notobjintf;
handler : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
pocall : pocall_internconst;
pooption : [];
pocall : pocall_none;
pooption : [po_internconst];
mutexclpocall : [];
mutexclpotype : [potype_operator];
mutexclpo : []
@ -1774,11 +1774,15 @@ const
end;
{ internconst or internproc only need to be defined once }
if (hd.proccalloption in [pocall_internconst,pocall_internproc]) then
if (hd.proccalloption=pocall_internproc) then
aprocdef.proccalloption:=hd.proccalloption
else
if (aprocdef.proccalloption in [pocall_internconst,pocall_internproc]) then
if (aprocdef.proccalloption=pocall_internproc) then
hd.proccalloption:=aprocdef.proccalloption;
if (po_internconst in hd.procoptions) then
include(aprocdef.procoptions,po_internconst)
else if (po_internconst in aprocdef.procoptions) then
include(hd.procoptions,po_internconst);
{ Check calling convention }
if (hd.proccalloption<>aprocdef.proccalloption) then
@ -1957,7 +1961,13 @@ const
end.
{
$Log$
Revision 1.65 2002-08-18 20:06:24 peter
Revision 1.66 2002-08-19 19:36:44 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.65 2002/08/18 20:06:24 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu

11
compiler/symconst.pas
View File

@ -191,7 +191,8 @@ type
po_overload, { procedure is declared with overload directive }
po_varargs, { printf like arguments }
po_leftright, { push arguments from left to right }
po_clearstack { caller clears the stack }
po_clearstack, { caller clears the stack }
po_internconst { procedure has constant evaluator intern }
);
tprocoptions=set of tprocoption;
@ -334,7 +335,13 @@ implementation
end.
{
$Log$
Revision 1.33 2002-07-01 16:23:54 peter
Revision 1.34 2002-08-19 19:36:44 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.33 2002/07/01 16:23:54 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)

22
compiler/utils/ppudump.pp
View File

@ -516,7 +516,6 @@ type
pocall_far16, { Far16 for OS/2 }
pocall_fpccall, { FPC default calling }
pocall_inline, { Procedure is an assembler macro }
pocall_internconst, { procedure has constant evaluator intern }
pocall_internproc, { Procedure has compiler magic}
pocall_palmossyscall, { procedure is a PalmOS system call }
pocall_pascal, { pascal standard left to right }
@ -553,7 +552,10 @@ type
po_savestdregs, { save std regs cdecl and stdcall need that ! }
po_saveregisters, { save all registers }
po_overload, { procedure is declared with overload directive }
po_varargs { printf like arguments }
po_varargs, { printf like arguments }
po_leftright, { push arguments from left to right }
po_clearstack, { caller clears the stack }
po_internconst { procedure has constant evaluator intern }
);
tprocoptions=set of tprocoption;
function read_abstract_proc_def:tproccalloption;
@ -578,7 +580,6 @@ const
'Far16',
'FPCCall',
'Inline',
'InternConst',
'InternProc',
'PalmOSSysCall',
'Pascal',
@ -596,7 +597,7 @@ const
(mask:potype_destructor; str:'Destructor'),
(mask:potype_operator; str:'Operator')
);
procopts=18;
procopts=21;
procopt : array[1..procopts] of tprocopt=(
(mask:po_classmethod; str:'ClassMethod'),
(mask:po_virtualmethod; str:'VirtualMethod'),
@ -615,7 +616,10 @@ const
(mask:po_savestdregs; str:'SaveStdRegs'),
(mask:po_saveregisters; str:'SaveRegisters'),
(mask:po_overload; str:'Overload'),
(mask:po_varargs; str:'VarArgs')
(mask:po_varargs; str:'VarArgs'),
(mask:po_leftright; str:'LeftRight'),
(mask:po_clearstack; str:'ClearStack'),
(mask:po_internconst; str:'InternConst')
);
tvarspez : array[0..3] of string[5]=('Value','Const','Var ','Out ');
var
@ -1824,7 +1828,13 @@ begin
end.
{
$Log$
Revision 1.27 2002-08-15 15:15:56 carl
Revision 1.28 2002-08-19 19:36:44 peter
* More fixes for cross unit inlining, all tnodes are now implemented
* Moved pocall_internconst to po_internconst because it is not a
calling type at all and it conflicted when inlining of these small
functions was requested
Revision 1.27 2002/08/15 15:15:56 carl
* jmpbuf size allocation for exceptions is now cpu specific (as it should)
* more generic nodes for maths
* several fixes for better m68k support