paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-07 20:50:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ add functionality to store a node tree's required temp nodes and their flag upon entering the tree

Browse Source 
git-svn-id: trunk@44924 -
This commit is contained in:
svenbarth 2020-04-21 06:04:59 +00:00
parent 41b1711589
commit 12ef066897
1 changed files with 153 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
compiler/psub.pas
View File

@ -28,13 +28,23 @@ unit psub;
interface
uses
globals,
node,nbas,
globals,cclasses,
node,nbas,nutils,
symdef,procinfo,optdfa;
type
tcgprocinfo = class(tprocinfo)
private type
ttempinfo_flags_entry = record
tempinfo : ptempinfo;
flags : ttempinfoflags;
end;
ptempinfo_flags_entry = ^ttempinfo_flags_entry;
private
tempinfo_flags_map : TFPList;
tempflags_swapped : boolean;
procedure swap_tempflags;
function store_node_tempflags(var n: tnode; arg: pointer): foreachnoderesult;
procedure CreateInlineInfo;
{ returns the node which is the start of the user code, this is needed by the dfa }
function GetUserCode: tnode;
@ -67,6 +77,10 @@ interface
procedure remove_from_symtablestack;
procedure parse_body;
procedure store_tempflags;
procedure apply_tempflags;
procedure reset_tempflags;
function has_assembler_child : boolean;
procedure set_eh_info; override;
{$ifdef DEBUG_NODE_XML}
@ -103,7 +117,7 @@ implementation
uses
sysutils,
{ common }
cutils, cmsgs, cclasses,
cutils, cmsgs,
{ global }
globtype,tokens,verbose,comphook,constexp,
systems,cpubase,aasmbase,aasmtai,aasmdata,
@ -112,7 +126,7 @@ implementation
paramgr,
fmodule,
{ pass 1 }
nutils,ngenutil,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
ngenutil,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
pass_1,
{$ifdef state_tracking}
nstate,
@ -706,7 +720,15 @@ implementation
****************************************************************************}
destructor tcgprocinfo.destroy;
var
i : longint;
begin
if assigned(tempinfo_flags_map) then
begin
for i:=0 to tempinfo_flags_map.count-1 do
dispose(ptempinfo_flags_entry(tempinfo_flags_map[i]));
tempinfo_flags_map.free;
end;
code.free;
inherited destroy;
end;
@ -1270,6 +1292,133 @@ implementation
end;
function tcgprocinfo.store_node_tempflags(var n: tnode; arg: pointer): foreachnoderesult;
var
nodeset : THashSet absolute arg;
entry : ptempinfo_flags_entry;
i : longint;
hashsetitem: PHashSetItem;
begin
result:=fen_true;
case n.nodetype of
tempcreaten:
begin
{$ifdef EXTDEBUG}
comment(V_Debug,'keeping track of new temp node: '+hexstr(ttempbasenode(n).tempinfo));
{$endif EXTDEBUG}
nodeset.FindOrAdd(ttempbasenode(n).tempinfo,sizeof(pointer));
end;
tempdeleten:
begin
{$ifdef EXTDEBUG}
comment(V_Debug,'got temp delete node: '+hexstr(ttempbasenode(n).tempinfo));
{$endif EXTDEBUG}
{ don't remove temp nodes so that outside code can know if some temp
was only created in here }
(*hashsetitem:=nodeset.find(ttempbasenode(n).tempinfo,sizeof(pointer));
if assigned(hashsetitem) then
begin
{$ifdef EXTDEBUG}
comment(V_Debug,'no longer keeping track of temp node');
{$endif EXTDEBUG}
writeln('no longer keeping track of temp node');
nodeset.Remove(hashsetitem);
end;*)
end;
temprefn:
begin
{$ifdef EXTDEBUG}
comment(V_Debug,'found temp ref node: '+hexstr(ttempbasenode(n).tempinfo));
{$endif EXTDEBUG}
if not assigned(nodeset.find(ttempbasenode(n).tempinfo,sizeof(pointer))) then
begin
for i:=0 to tempinfo_flags_map.count-1 do
begin
entry:=ptempinfo_flags_entry(tempinfo_flags_map[i]);
{$ifdef EXTDEBUG}
comment(V_Debug,'comparing with tempinfo: '+hexstr(entry^.tempinfo));
{$endif EXTDEBUG}
if entry^.tempinfo=ttempbasenode(n).tempinfo then
begin
{$ifdef EXTDEBUG}
comment(V_Debug,'temp node exists');
{$endif EXTDEBUG}
exit;
end;
end;
{$ifdef EXTDEBUG}
comment(V_Debug,'storing node');
{$endif EXTDEBUG}
new(entry);
entry^.tempinfo:=ttempbasenode(n).tempinfo;
entry^.flags:=ttempinfoaccessor.gettempinfoflags(entry^.tempinfo);
tempinfo_flags_map.add(entry);
end
else
begin
{$ifdef EXTDEBUG}
comment(V_Debug,'ignoring node');
{$endif EXTDEBUG}
end;
end;
else
;
end;
end;
procedure tcgprocinfo.store_tempflags;
var
nodeset : THashSet;
begin
if assigned(tempinfo_flags_map) then
internalerror(2020040601);
{$ifdef EXTDEBUG}
comment(V_Debug,'storing temp nodes of '+procdef.mangledname);
{$endif EXTDEBUG}
tempinfo_flags_map:=tfplist.create;
nodeset:=THashSet.Create(32,false,false);
foreachnode(code,@store_node_tempflags,nodeset);
nodeset.free;
end;
procedure tcgprocinfo.swap_tempflags;
var
entry : ptempinfo_flags_entry;
i : longint;
tempflags : ttempinfoflags;
begin
if not assigned(tempinfo_flags_map) then
exit;
for i:=0 to tempinfo_flags_map.count-1 do
begin
entry:=ptempinfo_flags_entry(tempinfo_flags_map[i]);
tempflags:=ttempinfoaccessor.gettempinfoflags(entry^.tempinfo);
ttempinfoaccessor.settempinfoflags(entry^.tempinfo,entry^.flags);
entry^.flags:=tempflags;
end;
end;
procedure tcgprocinfo.apply_tempflags;
begin
if tempflags_swapped then
internalerror(2020040602);
swap_tempflags;
tempflags_swapped:=true;
end;
procedure tcgprocinfo.reset_tempflags;
begin
if not tempflags_swapped then
internalerror(2020040603);
swap_tempflags;
tempflags_swapped:=false;
end;
{$ifdef DEBUG_NODE_XML}
procedure tcgprocinfo.XMLPrintProc;
var