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

+ TEMPREGDEBUG code, test of register allocation

Browse Source 
if a tree uses more than registers32 regs then
    internalerror(10) is issued
  + EXTTEMPREGDEBUG will also give internalerror(10) if
    a same register is freed twice (happens in several part
    of current compiler like addn for strings and sets)
This commit is contained in:
pierre 1999-08-23 23:25:58 +00:00
parent 1ec81566cc
commit 409b092c87
3 changed files with 179 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
compiler/pass_2.pas
View File

@ -261,13 +261,21 @@ implementation
oldcodegenerror : boolean; oldcodegenerror : boolean;
oldlocalswitches : tlocalswitches; oldlocalswitches : tlocalswitches;
oldpos : tfileposinfo; oldpos : tfileposinfo;
{$ifdef TEMPREGDEBUG}
prevp : pptree;
{$endif TEMPREGDEBUG}
begin begin
if not(p^.error) then if not(p^.error) then
begin begin
oldcodegenerror:=codegenerror; oldcodegenerror:=codegenerror;
oldlocalswitches:=aktlocalswitches; oldlocalswitches:=aktlocalswitches;
oldpos:=aktfilepos; oldpos:=aktfilepos;
testregisters32;
{$ifdef TEMPREGDEBUG}
prevp:=curptree;
curptree:=@p;
p^.usableregs:=usablereg32;
{$endif TEMPREGDEBUG}
aktfilepos:=p^.fileinfo; aktfilepos:=p^.fileinfo;
aktlocalswitches:=p^.localswitches; aktlocalswitches:=p^.localswitches;
codegenerror:=false; codegenerror:=false;
@ -277,6 +285,9 @@ implementation
codegenerror:=codegenerror or oldcodegenerror; codegenerror:=codegenerror or oldcodegenerror;
aktlocalswitches:=oldlocalswitches; aktlocalswitches:=oldlocalswitches;
aktfilepos:=oldpos; aktfilepos:=oldpos;
{$ifdef TEMPREGDEBUG}
curptree:=prevp;
{$endif TEMPREGDEBUG}
end end
else else
codegenerror:=true; codegenerror:=true;
@ -653,7 +664,15 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.31 1999-08-07 14:20:59 florian Revision 1.32 1999-08-23 23:25:59 pierre
+ TEMPREGDEBUG code, test of register allocation
if a tree uses more than registers32 regs then
internalerror(10) is issued
+ EXTTEMPREGDEBUG will also give internalerror(10) if
a same register is freed twice (happens in several part
of current compiler like addn for strings and sets)
Revision 1.31 1999/08/07 14:20:59 florian
* some small problems fixed * some small problems fixed
Revision 1.30 1999/08/04 14:21:07 florian Revision 1.30 1999/08/04 14:21:07 florian

136
compiler/tgeni386.pas
View File

@ -44,6 +44,9 @@ unit tgeni386;
usableregmmx : byte = 8; usableregmmx : byte = 8;
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
{$ifdef TEMPREGDEBUG}
procedure testregisters32;
{$endif TEMPREGDEBUG}
function getregister32 : tregister; function getregister32 : tregister;
procedure ungetregister32(r : tregister); procedure ungetregister32(r : tregister);
{ tries to allocate the passed register, if possible } { tries to allocate the passed register, if possible }
@ -88,9 +91,17 @@ unit tgeni386;
{$ifdef SUPPORT_MMX} {$ifdef SUPPORT_MMX}
reg_pushes : array[R_EAX..R_MM6] of longint; reg_pushes : array[R_EAX..R_MM6] of longint;
is_reg_var : array[R_EAX..R_MM6] of boolean; is_reg_var : array[R_EAX..R_MM6] of boolean;
{$ifdef TEMPREGDEBUG}
reg_user : array[R_EAX..R_MM6] of ptree;
reg_releaser : array[R_EAX..R_MM6] of ptree;
{$endif TEMPREGDEBUG}
{$else SUPPORT_MMX} {$else SUPPORT_MMX}
reg_pushes : array[R_EAX..R_EDI] of longint; reg_pushes : array[R_EAX..R_EDI] of longint;
is_reg_var : array[R_EAX..R_EDI] of boolean; is_reg_var : array[R_EAX..R_EDI] of boolean;
{$ifdef TEMPREGDEBUG}
reg_user : array[R_EAX..R_EDI] of ptree;
reg_releaser : array[R_EAX..R_EDI] of ptree;
{$endif TEMPREGDEBUG}
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
@ -126,7 +137,12 @@ implementation
often, but there must be a better way often, but there must be a better way
maybe by putting the value back to the stack !! } maybe by putting the value back to the stack !! }
if not(is_reg_var[r]) then if not(is_reg_var[r]) then
begin
unused:=unused+[r]; unused:=unused+[r];
{$ifdef TEMPREGDEBUG}
inc(usablereg32);
{$endif TEMPREGDEBUG}
end;
pushed[r]:=true; pushed[r]:=true;
end; end;
end; end;
@ -146,11 +162,19 @@ implementation
exprasmlist^.concat(new(pai386,op_reg_ref( exprasmlist^.concat(new(pai386,op_reg_ref(
A_MOVQ,S_NO,r,hr))); A_MOVQ,S_NO,r,hr)));
if not(is_reg_var[r]) then if not(is_reg_var[r]) then
begin
unused:=unused+[r]; unused:=unused+[r];
{$ifdef TEMPREGDEBUG}
inc(usableregmmx);
{$endif TEMPREGDEBUG}
end;
pushed[r]:=true; pushed[r]:=true;
end; end;
end; end;
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
{$ifdef TEMPREGDEBUG}
testregisters32;
{$endif TEMPREGDEBUG}
end; end;
procedure saveusedregisters(var saved : tsaved;b : byte); procedure saveusedregisters(var saved : tsaved;b : byte);
@ -181,7 +205,12 @@ implementation
often, but there must be a better way often, but there must be a better way
maybe by putting the value back to the stack !! } maybe by putting the value back to the stack !! }
if not(is_reg_var[r]) then if not(is_reg_var[r]) then
begin
unused:=unused+[r]; unused:=unused+[r];
{$ifdef TEMPREGDEBUG}
inc(usablereg32);
{$endif TEMPREGDEBUG}
end;
end; end;
end; end;
end; end;
@ -196,11 +225,19 @@ implementation
exprasmlist^.concat(new(pai386,op_reg_ref( exprasmlist^.concat(new(pai386,op_reg_ref(
A_MOVQ,S_NO,r,newreference(hr)))); A_MOVQ,S_NO,r,newreference(hr))));
if not(is_reg_var[r]) then if not(is_reg_var[r]) then
begin
unused:=unused+[r]; unused:=unused+[r];
{$ifdef TEMPREGDEBUG}
inc(usableregmmx);
{$endif TEMPREGDEBUG}
end;
saved[r]:=hr.offset; saved[r]:=hr.offset;
end; end;
end; end;
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
{$ifdef TEMPREGDEBUG}
testregisters32;
{$endif TEMPREGDEBUG}
end; end;
procedure popusedregisters(const pushed : tpushed); procedure popusedregisters(const pushed : tpushed);
@ -225,6 +262,9 @@ implementation
exprasmlist^.concat(new(pai386,op_const_reg( exprasmlist^.concat(new(pai386,op_const_reg(
A_ADD,S_L,8,R_ESP))); A_ADD,S_L,8,R_ESP)));
unused:=unused-[r]; unused:=unused-[r];
{$ifdef TEMPREGDEBUG}
dec(usableregmmx);
{$endif TEMPREGDEBUG}
end; end;
end; end;
{$endif SUPPORT_MMX} {$endif SUPPORT_MMX}
@ -232,8 +272,20 @@ implementation
if pushed[r] then if pushed[r] then
begin begin
exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,r))); exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,r)));
{$ifdef TEMPREGDEBUG}
if not (r in unused) then
{ internalerror(10)
in cg386cal we always restore regs
that appear as used
due to a unused tmep storage PM }
else
dec(usablereg32);
{$endif TEMPREGDEBUG}
unused:=unused-[r]; unused:=unused-[r];
end; end;
{$ifdef TEMPREGDEBUG}
testregisters32;
{$endif TEMPREGDEBUG}
end; end;
procedure restoreusedregisters(const saved : tsaved); procedure restoreusedregisters(const saved : tsaved);
@ -254,6 +306,9 @@ implementation
exprasmlist^.concat(new(pai386,op_ref_reg( exprasmlist^.concat(new(pai386,op_ref_reg(
A_MOVQ,S_NO,newreference(hr),r))); A_MOVQ,S_NO,newreference(hr),r)));
unused:=unused-[r]; unused:=unused-[r];
{$ifdef TEMPREGDEBUG}
dec(usableregmmx);
{$endif TEMPREGDEBUG}
ungetiftemp(hr); ungetiftemp(hr);
end; end;
end; end;
@ -265,9 +320,18 @@ implementation
hr.base:=frame_pointer; hr.base:=frame_pointer;
hr.offset:=saved[r]; hr.offset:=saved[r];
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(hr),r))); exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(hr),r)));
{$ifdef TEMPREGDEBUG}
if not (r in unused) then
internalerror(10)
else
dec(usablereg32);
{$endif TEMPREGDEBUG}
unused:=unused-[r]; unused:=unused-[r];
ungetiftemp(hr); ungetiftemp(hr);
end; end;
{$ifdef TEMPREGDEBUG}
testregisters32;
{$endif TEMPREGDEBUG}
end; end;
procedure ungetregister(r : tregister); procedure ungetregister(r : tregister);
@ -301,10 +365,25 @@ implementation
begin begin
if not(r in [R_EAX,R_EBX,R_ECX,R_EDX]) then if not(r in [R_EAX,R_EBX,R_ECX,R_EDX]) then
exit; exit;
unused:=unused+[r]; {$ifdef TEMPREGDEBUG}
if (r in unused) then
{$ifdef EXTTEMPREGDEBUG}
internalerror(10)
{$else EXTTEMPREGDEBUG}
exit
{$endif EXTTEMPREGDEBUG}
else
{$endif TEMPREGDEBUG}
inc(usablereg32); inc(usablereg32);
unused:=unused+[r];
{$ifdef TEMPREGDEBUG}
reg_releaser[r]:=curptree^;
{$endif TEMPREGDEBUG}
end; end;
exprasmlist^.concat(new(pairegalloc,dealloc(r))); exprasmlist^.concat(new(pairegalloc,dealloc(r)));
{$ifdef TEMPREGDEBUG}
testregisters32;
{$endif TEMPREGDEBUG}
end; end;
{$ifdef SUPPORT_MMX} {$ifdef SUPPORT_MMX}
@ -377,16 +456,41 @@ implementation
end; end;
{$ifdef TEMPREGDEBUG}
procedure testregisters32;
var test : byte;
begin
test:=0;
if R_EAX in unused then
inc(test);
if R_EBX in unused then
inc(test);
if R_ECX in unused then
inc(test);
if R_EDX in unused then
inc(test);
if test<>usablereg32 then
internalerror(10);
end;
{$endif TEMPREGDEBUG}
function getregister32 : tregister; function getregister32 : tregister;
begin begin
if usablereg32=0 then if usablereg32=0 then
internalerror(10); internalerror(10);
dec(usablereg32); dec(usablereg32);
{$ifdef TEMPREGDEBUG}
if curptree^^.usableregs-usablereg32>curptree^^.registers32 then
internalerror(10);
{$endif TEMPREGDEBUG}
if R_EAX in unused then if R_EAX in unused then
begin begin
unused:=unused-[R_EAX]; unused:=unused-[R_EAX];
usedinproc:=usedinproc or ($80 shr byte(R_EAX)); usedinproc:=usedinproc or ($80 shr byte(R_EAX));
getregister32:=R_EAX; getregister32:=R_EAX;
{$ifdef TEMPREGDEBUG}
reg_user[R_EAX]:=curptree^;
{$endif TEMPREGDEBUG}
exprasmlist^.concat(new(pairegalloc,alloc(R_EAX))); exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
end end
else if R_EDX in unused then else if R_EDX in unused then
@ -394,6 +498,9 @@ implementation
unused:=unused-[R_EDX]; unused:=unused-[R_EDX];
usedinproc:=usedinproc or ($80 shr byte(R_EDX)); usedinproc:=usedinproc or ($80 shr byte(R_EDX));
getregister32:=R_EDX; getregister32:=R_EDX;
{$ifdef TEMPREGDEBUG}
reg_user[R_EDX]:=curptree^;
{$endif TEMPREGDEBUG}
exprasmlist^.concat(new(pairegalloc,alloc(R_EDX))); exprasmlist^.concat(new(pairegalloc,alloc(R_EDX)));
end end
else if R_EBX in unused then else if R_EBX in unused then
@ -401,6 +508,9 @@ implementation
unused:=unused-[R_EBX]; unused:=unused-[R_EBX];
usedinproc:=usedinproc or ($80 shr byte(R_EBX)); usedinproc:=usedinproc or ($80 shr byte(R_EBX));
getregister32:=R_EBX; getregister32:=R_EBX;
{$ifdef TEMPREGDEBUG}
reg_user[R_EBX]:=curptree^;
{$endif TEMPREGDEBUG}
exprasmlist^.concat(new(pairegalloc,alloc(R_EBX))); exprasmlist^.concat(new(pairegalloc,alloc(R_EBX)));
end end
else if R_ECX in unused then else if R_ECX in unused then
@ -408,9 +518,15 @@ implementation
unused:=unused-[R_ECX]; unused:=unused-[R_ECX];
usedinproc:=usedinproc or ($80 shr byte(R_ECX)); usedinproc:=usedinproc or ($80 shr byte(R_ECX));
getregister32:=R_ECX; getregister32:=R_ECX;
{$ifdef TEMPREGDEBUG}
reg_user[R_ECX]:=curptree^;
{$endif TEMPREGDEBUG}
exprasmlist^.concat(new(pairegalloc,alloc(R_ECX))); exprasmlist^.concat(new(pairegalloc,alloc(R_ECX)));
end end
else internalerror(10); else internalerror(10);
{$ifdef TEMPREGDEBUG}
testregisters32;
{$endif TEMPREGDEBUG}
end; end;
function getexplicitregister32(r : tregister) : tregister; function getexplicitregister32(r : tregister) : tregister;
@ -419,10 +535,18 @@ implementation
if r in unused then if r in unused then
begin begin
dec(usablereg32); dec(usablereg32);
{$ifdef TEMPREGDEBUG}
if curptree^^.usableregs-usablereg32>curptree^^.registers32 then
internalerror(10);
reg_user[r]:=curptree^;
{$endif TEMPREGDEBUG}
unused:=unused-[r]; unused:=unused-[r];
usedinproc:=usedinproc or ($80 shr byte(r)); usedinproc:=usedinproc or ($80 shr byte(r));
exprasmlist^.concat(new(pairegalloc,alloc(r))); exprasmlist^.concat(new(pairegalloc,alloc(r)));
getexplicitregister32:=r; getexplicitregister32:=r;
{$ifdef TEMPREGDEBUG}
testregisters32;
{$endif TEMPREGDEBUG}
end end
else else
getexplicitregister32:=getregister32; getexplicitregister32:=getregister32;
@ -482,7 +606,15 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.31 1999-08-10 12:47:55 pierre Revision 1.32 1999-08-23 23:25:58 pierre
+ TEMPREGDEBUG code, test of register allocation
if a tree uses more than registers32 regs then
internalerror(10) is issued
+ EXTTEMPREGDEBUG will also give internalerror(10) if
a same register is freed twice (happens in several part
of current compiler like addn for strings and sets)
Revision 1.31 1999/08/10 12:47:55 pierre
* fpuvaroffset problems solved * fpuvaroffset problems solved
Revision 1.30 1999/08/04 13:45:32 florian Revision 1.30 1999/08/04 13:45:32 florian

21
compiler/tree.pas
View File

@ -198,6 +198,9 @@ unit tree;
{$ifdef extdebug} {$ifdef extdebug}
firstpasscount : longint; firstpasscount : longint;
{$endif extdebug} {$endif extdebug}
{$ifdef TEMPREGDEBUG}
usableregs : longint;
{$endif TEMPREGDEBUG}
{$ifdef TEMPS_NOT_PUSH} {$ifdef TEMPS_NOT_PUSH}
temp_offset : longint; temp_offset : longint;
{$endif TEMPS_NOT_PUSH} {$endif TEMPS_NOT_PUSH}
@ -312,6 +315,14 @@ unit tree;
{ searches the lowest label } { searches the lowest label }
function case_get_min(root : pcaserecord) : longint; function case_get_min(root : pcaserecord) : longint;
type
pptree = ^ptree;
{$ifdef TEMPREGDEBUG}
const
curptree : pptree = nil;
{$endif TEMPREGDEBUG}
{$I innr.inc} {$I innr.inc}
implementation implementation
@ -1739,7 +1750,15 @@ unit tree;
end. end.
{ {
$Log$ $Log$
Revision 1.90 1999-08-17 13:26:09 peter Revision 1.91 1999-08-23 23:26:00 pierre
+ TEMPREGDEBUG code, test of register allocation
if a tree uses more than registers32 regs then
internalerror(10) is issued
+ EXTTEMPREGDEBUG will also give internalerror(10) if
a same register is freed twice (happens in several part
of current compiler like addn for strings and sets)
Revision 1.90 1999/08/17 13:26:09 peter
* arrayconstructor -> arrayofconst fixed when arraycosntructor was not * arrayconstructor -> arrayofconst fixed when arraycosntructor was not
variant. variant.