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

* More gdb cleanup: make record & object stab generation linear instead

Browse Source 
of quadratic.
This commit is contained in:
daniel 2004-01-25 20:23:28 +00:00
parent c006ab8326
commit 60876a7c1a
1 changed files with 102 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
compiler/symdef.pas
View File

@ -208,15 +208,17 @@ interface
{$endif GDB} {$endif GDB}
end; end;
Trecord_stabgen_state=record
stabstring:Pchar;
stabsize,staballoc,recoffset:integer;
end;
tabstractrecorddef = class(tstoreddef) tabstractrecorddef = class(tstoreddef)
private private
Count : integer; Count : integer;
FRTTIType : trttitype; FRTTIType : trttitype;
{$ifdef GDB} {$ifdef GDB}
StabRecString : pchar; procedure addname(p:Tnamedindexitem;arg:pointer);
StabRecSize : Integer;
RecOffset : Integer;
procedure addname(p : tnamedindexitem;arg:pointer);
{$endif} {$endif}
procedure count_field_rtti(sym : tnamedindexitem;arg:pointer); procedure count_field_rtti(sym : tnamedindexitem;arg:pointer);
procedure write_field_rtti(sym : tnamedindexitem;arg:pointer); procedure write_field_rtti(sym : tnamedindexitem;arg:pointer);
@ -1157,11 +1159,10 @@ implementation
end; end;
end; end;
function tstoreddef.allstabstring : pchar; function tstoreddef.allstabstring : pchar;
var stabchar : string[2]; var stabchar : string[2];
ss,st,su : pchar; ss,st,su : pchar;
sname : string;
sym_line_no : longint;
begin begin
ss := stabstring; ss := stabstring;
stabchar := 't'; stabchar := 't';
@ -2964,16 +2965,17 @@ implementation
{$ifdef GDB} {$ifdef GDB}
procedure tabstractrecorddef.addname(p : tnamedindexitem;arg:pointer); procedure tabstractrecorddef.addname(p:Tnamedindexitem;arg:pointer);
var
news, newrec : pchar; var newrec:Pchar;
spec : string[3]; spec:string[3];
varsize : longint; varsize:longint;
state:^Trecord_stabgen_state;
begin begin
state:=arg;
{ static variables from objects are like global objects } { static variables from objects are like global objects }
if (sp_static in tsym(p).symoptions) then if (Tsym(p).typ=varsym) and not (sp_static in Tsym(p).symoptions) then
exit;
If tsym(p).typ = varsym then
begin begin
if (sp_protected in tsym(p).symoptions) then if (sp_protected in tsym(p).symoptions) then
spec:='/1' spec:='/1'
@ -2981,8 +2983,6 @@ implementation
spec:='/0' spec:='/0'
else else
spec:=''; spec:='';
if not assigned(tvarsym(p).vartype.def) then
writeln(tvarsym(p).name);
{ class fields are pointers PM, obsolete now PM } { class fields are pointers PM, obsolete now PM }
{if (tvarsym(p).vartype.def.deftype=objectdef) and {if (tvarsym(p).vartype.def.deftype=objectdef) and
tobjectdef(tvarsym(p).vartype.def).is_class then tobjectdef(tvarsym(p).vartype.def).is_class then
@ -2994,15 +2994,16 @@ implementation
newrec:=stabstr_evaluate('$1:$2,$3,$4;',[p.name, newrec:=stabstr_evaluate('$1:$2,$3,$4;',[p.name,
spec+tstoreddef(tvarsym(p).vartype.def).numberstring, spec+tstoreddef(tvarsym(p).vartype.def).numberstring,
tostr(tvarsym(p).fieldoffset*8),tostr(varsize*8)]); tostr(tvarsym(p).fieldoffset*8),tostr(varsize*8)]);
if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then if state^.stabsize+strlen(newrec)>=state^.staballoc-256 then
begin begin
inc(stabrecsize,memsizeinc); inc(state^.staballoc,memsizeinc);
reallocmem(stabrecstring,stabrecsize); reallocmem(state^.stabstring,state^.staballoc);
end; end;
strcat(StabRecstring,newrec); strcopy(state^.stabstring+state^.stabsize,newrec);
inc(state^.stabsize,strlen(newrec));
strdispose(newrec); strdispose(newrec);
{This should be used for case !!} {This should be used for case !!}
inc(RecOffset,tvarsym(p).vartype.def.size); inc(state^.recoffset,Tvarsym(p).vartype.def.size);
end; end;
end; end;
{$endif GDB} {$endif GDB}
@ -3173,15 +3174,21 @@ implementation
{$ifdef GDB} {$ifdef GDB}
function trecorddef.stabstring : pchar; function trecorddef.stabstring : pchar;
var state:Trecord_stabgen_state;
begin begin
GetMem(stabrecstring,memsizeinc); getmem(state.stabstring,memsizeinc);
stabrecsize:=memsizeinc; state.staballoc:=memsizeinc;
strpcopy(stabRecString,'s'+tostr(size)); strpcopy(state.stabstring,'s'+tostr(size));
RecOffset := 0; state.recoffset:=0;
symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,nil); state.stabsize:=strlen(state.stabstring);
strpcopy(strend(StabRecString),';'); symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,@state);
reallocmem(stabrecstring,strlen(stabrecstring)); { strpcopy(strend(state.stabstring),';');}
stabstring:=stabrecstring; state.stabstring[state.stabsize]:=';';
state.stabstring[state.stabsize+1]:=#0;
reallocmem(state.stabstring,state.stabsize+2);
stabstring:=state.stabstring;
end; end;
@ -4551,7 +4558,7 @@ implementation
Please do not remove this part Please do not remove this part
might be used once might be used once
gdb for pascal is ready PM } gdb for pascal is ready PM }
(* {$ifdef disabled}
param := para1; param := para1;
i := 0; i := 0;
while assigned(param) do while assigned(param) do
@ -4563,7 +4570,8 @@ implementation
strcat(nss,pst); strcat(nss,pst);
strdispose(pst); strdispose(pst);
param := param^.next; param := param^.next;
end; *) end;
{$endif}
{strpcopy(strend(nss),';');} {strpcopy(strend(nss),';');}
stabstring := strnew(nss); stabstring := strnew(nss);
freemem(nss,1024); freemem(nss,1024);
@ -5082,14 +5090,17 @@ implementation
{$ifdef GDB} {$ifdef GDB}
procedure tobjectdef.addprocname(p :tnamedindexitem;arg:pointer); procedure tobjectdef.addprocname(p :tnamedindexitem;arg:pointer);
var virtualind,argnames : string; var virtualind,argnames : string;
news, newrec : pchar; newrec : pchar;
pd,ipd : tprocdef; pd,ipd : tprocdef;
lindex : longint; lindex : longint;
para : TParaItem; para : TParaItem;
arglength : byte; arglength : byte;
sp : char; sp : char;
state:^Trecord_stabgen_state;
olds:integer;
begin begin
If tsym(p).typ = procsym then state:=arg;
if tsym(p).typ = procsym then
begin begin
pd := tprocsym(p).first_procdef; pd := tprocsym(p).first_procdef;
{ this will be used for full implementation of object stabs { this will be used for full implementation of object stabs
@ -5153,12 +5164,14 @@ implementation
Tstoreddef(pd.rettype.def).numberstring,argnames,sp, Tstoreddef(pd.rettype.def).numberstring,argnames,sp,
virtualind]); virtualind]);
{ get spare place for a string at the end } { get spare place for a string at the end }
if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then olds:=state^.stabsize;
inc(state^.stabsize,strlen(newrec));
if state^.stabsize>=state^.staballoc-256 then
begin begin
inc(stabrecsize,memsizeinc); inc(state^.staballoc,memsizeinc);
reallocmem(stabrecstring,stabrecsize); reallocmem(state^.stabstring,state^.staballoc);
end; end;
strcat(StabRecstring,newrec); strcopy(state^.stabstring+olds,newrec);
strdispose(newrec); strdispose(newrec);
{This should be used for case !! {This should be used for case !!
RecOffset := RecOffset + pd.size;} RecOffset := RecOffset + pd.size;}
@ -5168,50 +5181,46 @@ implementation
function tobjectdef.stabstring : pchar; function tobjectdef.stabstring : pchar;
var anc : tobjectdef; var anc : tobjectdef;
oldrec : pchar; state:Trecord_stabgen_state;
oldrecsize,oldrecoffset : longint; ts : string;
str_end : string;
begin begin
if not (objecttype=odt_class) or writing_class_record_stab then if not (objecttype=odt_class) or writing_class_record_stab then
begin begin
oldrec := stabrecstring; state.staballoc:=memsizeinc;
oldrecsize:=stabrecsize; getmem(state.stabstring,state.staballoc);
stabrecsize:=memsizeinc; strpcopy(state.stabstring,'s'+tostr(tobjectsymtable(symtable).datasize));
GetMem(stabrecstring,stabrecsize);
strpcopy(stabRecString,'s'+tostr(tobjectsymtable(symtable).datasize));
if assigned(childof) then if assigned(childof) then
begin begin
{only one ancestor not virtual, public, at base offset 0 } {only one ancestor not virtual, public, at base offset 0 }
{ !1 , 0 2 0 , } { !1 , 0 2 0 , }
strpcopy(strend(stabrecstring),'!1,020,'+childof.classnumberstring+';'); strpcopy(strend(state.stabstring),'!1,020,'+childof.classnumberstring+';');
end; end;
{virtual table to implement yet} {virtual table to implement yet}
OldRecOffset:=RecOffset; state.recoffset:=0;
RecOffset := 0; state.stabsize:=strlen(state.stabstring);
symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,nil); symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,@state);
RecOffset:=OldRecOffset;
if (oo_has_vmt in objectoptions) then if (oo_has_vmt in objectoptions) then
if not assigned(childof) or not(oo_has_vmt in childof.objectoptions) then if not assigned(childof) or not(oo_has_vmt in childof.objectoptions) then
begin begin
strpcopy(strend(stabrecstring),'$vf'+classnumberstring+':'+typeglobalnumber('vtblarray') ts:='$vf'+classnumberstring+':'+typeglobalnumber('vtblarray')+','+tostr(vmt_offset*8)+';';
+','+tostr(vmt_offset*8)+';'); strpcopy(state.stabstring+state.stabsize,ts);
inc(state.stabsize,length(ts));
end; end;
symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addprocname,nil); symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addprocname,@state);
if (oo_has_vmt in objectoptions) then if (oo_has_vmt in objectoptions) then
begin begin
anc := self; anc := self;
while assigned(anc.childof) and (oo_has_vmt in anc.childof.objectoptions) do while assigned(anc.childof) and (oo_has_vmt in anc.childof.objectoptions) do
anc := anc.childof; anc := anc.childof;
{ just in case anc = self } { just in case anc = self }
str_end:=';~%'+anc.classnumberstring+';'; ts:=';~%'+anc.classnumberstring+';';
end end
else else
str_end:=';'; ts:=';';
strpcopy(strend(stabrecstring),str_end); strpcopy(state.stabstring+state.stabsize,ts);
stabstring := strnew(StabRecString); inc(state.stabsize,length(ts));
freemem(stabrecstring,stabrecsize); reallocmem(state.stabstring,state.stabsize+1);
stabrecstring := oldrec; stabstring:=state.stabstring;
stabrecsize:=oldrecsize;
end end
else else
begin begin
@ -6182,7 +6191,11 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.205 2004-01-25 13:18:59 daniel Revision 1.206 2004-01-25 20:23:28 daniel
* More gdb cleanup: make record & object stab generation linear instead
of quadratic.
Revision 1.205 2004/01/25 13:18:59 daniel
* Made varags parameter constant * Made varags parameter constant
Revision 1.204 2004/01/25 12:37:15 daniel Revision 1.204 2004/01/25 12:37:15 daniel