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

* Experiment: Compress strings to save memory

Browse Source 
Did not save a single byte of mem; clearly the core size is boosted by
    temporary memory usage...
This commit is contained in:
daniel 2004-01-11 23:56:19 +00:00
parent ad451147d7
commit 4a4b8f2a72
8 changed files with 369 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
compiler/cclasses.pas
View File

@ -170,11 +170,11 @@ interface
FSpeedValue : cardinal;
{ singleList }
FListNext : TNamedIndexItem;
FName : Pstring;
protected
function GetName:string;virtual;
procedure SetName(const n:string);virtual;
public
FName : Pstring;
constructor Create;
constructor CreateName(const n:string);
destructor Destroy;override;
@ -870,7 +870,11 @@ end;
Fleft:=nil;
Fright:=nil;
Fspeedvalue:=cardinal($ffffffff);
{$ifdef compress}
FName:=stringdup(minilzw_encode(n));
{$else}
FName:=stringdup(n);
{$endif}
{ List }
FListNext:=nil;
end;
@ -888,7 +892,11 @@ end;
begin
if assigned(FName) then
stringdispose(FName);
{$ifdef compress}
FName:=stringdup(minilzw_encode(n));
{$else}
FName:=stringdup(n);
{$endif}
end;
end;
@ -896,7 +904,11 @@ end;
function TNamedIndexItem.GetName:string;
begin
if assigned(FName) then
{$ifdef compress}
Getname:=minilzw_decode(FName^)
{$else}
Getname:=FName^
{$endif}
else
Getname:='';
end;
@ -975,6 +987,11 @@ end;
var
p,SpeedValue : cardinal;
n : TNamedIndexItem;
{$ifdef compress}
senc:string;
{$else}
senc:string absolute s;
{$endif}
procedure insert_right_bottom(var root,Atree:TNamedIndexItem);
begin
@ -1005,10 +1022,10 @@ end;
lr:=left;
end;
end;
while (root<>nil) and (root.FName^<>s) do
while (root<>nil) and (root.FName^<>senc) do
begin
oldroot:=root;
if s<root.FName^ then
if senc<root.FName^ then
begin
root:=root.FRight;
lr:=right;
@ -1044,7 +1061,10 @@ end;
end;
begin
SpeedValue:=GetSpeedValue(s);
{$ifdef compress}
senc:=minilzw_encode(s);
{$endif}
SpeedValue:=GetSpeedValue(senc);
n:=FRoot;
if assigned(FHashArray) then
begin
@ -1053,7 +1073,7 @@ end;
p:=SpeedValue mod hasharraysize;
n:=FHashArray^[p];
if (n<>nil) and (n.SpeedValue=SpeedValue) and
(n.FName^=s) then
(n.FName^=senc) then
begin
{ The Node to delete is directly located under the
hasharray. Make the hasharray point to the left
@ -1075,7 +1095,7 @@ end;
begin
{ First check if the Node to delete is the root.}
if (FRoot<>nil) and (n.SpeedValue=SpeedValue) and
(n.FName^=s) then
(n.FName^=senc) then
begin
if n.FLeft<>nil then
begin
@ -1305,8 +1325,18 @@ end;
spdval : cardinal;
lasthp,
hp,hp2,hp3 : TNamedIndexItem;
{$ifdef compress}
oldsenc,newsenc:string;
{$else}
oldsenc:string absolute olds;
newsenc:string absolute news;
{$endif}
begin
spdval:=GetSpeedValue(olds);
{$ifdef compress}
oldsenc:=minilzw_encode(olds);
newsenc:=minilzw_encode(news);
{$endif}
spdval:=GetSpeedValue(oldsenc);
if assigned(FHashArray) then
hp:=FHashArray^[spdval mod hasharraysize]
else
@ -1327,7 +1357,7 @@ end;
end
else
begin
if (hp.FName^=olds) then
if (hp.FName^=oldsenc) then
begin
{ Get in hp2 the replacer for the root or hasharr }
hp2:=hp.FLeft;
@ -1358,8 +1388,8 @@ end;
hp.FLeft:=nil;
hp.FRight:=nil;
stringdispose(hp.FName);
hp.FName:=stringdup(newS);
hp.FSpeedValue:=GetSpeedValue(newS);
hp.FName:=stringdup(newsenc);
hp.FSpeedValue:=GetSpeedValue(newsenc);
{ reinsert }
if assigned(FHashArray) then
rename:=insertNode(hp,FHashArray^[hp.SpeedValue mod hasharraysize])
@ -1368,7 +1398,7 @@ end;
exit;
end
else
if olds>hp.FName^ then
if oldsenc>hp.FName^ then
begin
lasthp:=hp;
hp:=hp.FLeft
@ -1385,9 +1415,17 @@ end;
function Tdictionary.search(const s:string):TNamedIndexItem;
begin
search:=speedsearch(s,GetSpeedValue(s));
end;
var t:string;
begin
{$ifdef compress}
t:=minilzw_encode(s);
search:=speedsearch(t,getspeedvalue(t));
{$else}
search:=speedsearch(s,getspeedvalue(s));
{$endif}
end;
function Tdictionary.speedsearch(const s:string;SpeedValue:cardinal):TNamedIndexItem;
@ -1905,7 +1943,12 @@ end;
end.
{
$Log$
Revision 1.28 2003-10-23 14:44:07 peter
Revision 1.29 2004-01-11 23:56:19 daniel
* Experiment: Compress strings to save memory
Did not save a single byte of mem; clearly the core size is boosted by
temporary memory usage...
Revision 1.28 2003/10/23 14:44:07 peter
* splitted buildderef and buildderefimpl to fix interface crc
calculation

26
compiler/cgobj.pas
View File

@ -63,6 +63,9 @@ unit cgobj;
alignment : talignment;
rg : array[tregistertype] of trgobj;
t_times:cardinal;
{$ifdef flowgraph}
aktflownode:word;
{$endif}
{************************************************}
{ basic routines }
constructor create;
@ -72,6 +75,10 @@ unit cgobj;
{# Clean up the register allocators needed for the codegenerator.}
procedure done_register_allocators;virtual;
{$ifdef flowgraph}
procedure init_flowgraph;
procedure done_flowgraph;
{$endif}
{# Gets a register suitable to do integer operations on.}
function getintregister(list:Taasmoutput;size:Tcgsize):Tregister;virtual;
{# Gets a register suitable to do integer operations on.}
@ -590,6 +597,18 @@ implementation
add_reg_instruction_hook:=nil;
end;
{$ifdef flowgraph}
procedure Tcg.init_flowgraph;
begin
aktflownode:=0;
end;
procedure Tcg.done_flowgraph;
begin
end;
{$endif}
function tcg.getintregister(list:Taasmoutput;size:Tcgsize):Tregister;
begin
@ -2047,7 +2066,12 @@ finalization
end.
{
$Log$
Revision 1.146 2003-12-26 14:02:30 peter
Revision 1.147 2004-01-11 23:56:19 daniel
* Experiment: Compress strings to save memory
Did not save a single byte of mem; clearly the core size is boosted by
temporary memory usage...
Revision 1.146 2003/12/26 14:02:30 peter
* sparc updates
* use registertype in spill_register

154
compiler/cutils.pas
View File

@ -102,20 +102,19 @@ interface
{ ambivalent to pchar2pstring }
function pstring2pchar(p : pstring) : pchar;
{ Speed/Hash value }
{ Speed/Hash value }
Function GetSpeedValue(Const s:String):cardinal;
{ Ansistring (pchar+length) support }
procedure ansistringdispose(var p : pchar;length : longint);
function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
{*****************************************************************************
File Functions
*****************************************************************************}
{ Ansistring (pchar+length) support }
procedure ansistringdispose(var p : pchar;length : longint);
function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
function DeleteFile(const fn:string):boolean;
{Lzw encode/decode to compress strings -> save memory.}
function minilzw_encode(const s:string):string;
function minilzw_decode(const s:string):string;
implementation
@ -851,13 +850,145 @@ uses
DeleteFile:=(IOResult=0);
end;
{*****************************************************************************
Ultra basic KISS Lzw (de)compressor
*****************************************************************************}
{This is an extremely basic implementation of the Lzw algorithm. It
compresses 7-bit ASCII strings into 8-bit compressed strings.
The Lzw dictionary is preinitialized with 0..127, therefore this
part of the dictionary does not need to be stored in the arrays.
The Lzw code size is allways 8 bit, so we do not need complex code
that can write partial bytes.}
function minilzw_encode(const s:string):string;
var t,u,i:byte;
c:char;
data:array[128..255] of char;
previous:array[128..255] of byte;
lzwptr:byte;
next_avail:set of 0..255;
label l1;
begin
minilzw_encode:='';
if s<>'' then
begin
lzwptr:=127;
t:=byte(s[1]);
i:=2;
u:=128;
next_avail:=[];
while i<=length(s) do
begin
c:=s[i];
if not(t in next_avail) or (u>lzwptr) then goto l1;
while (previous[u]<>t) or (data[u]<>c) do
begin
inc(u);
if u>lzwptr then goto l1;
end;
t:=u;
inc(i);
continue;
l1:
{It's a pity that we still need those awfull tricks
with this modern compiler. Without this performance
of the entire procedure drops about 3 times.}
inc(minilzw_encode[0]);
minilzw_encode[length(minilzw_encode)]:=char(t);
if lzwptr=255 then
begin
lzwptr:=127;
next_avail:=[];
end
else
begin
inc(lzwptr);
data[lzwptr]:=c;
previous[lzwptr]:=t;
include(next_avail,t);
end;
t:=byte(c);
u:=128;
inc(i);
end;
inc(minilzw_encode[0]);
minilzw_encode[length(minilzw_encode)]:=char(t);
end;
end;
function minilzw_decode(const s:string):string;
var oldc,newc,c:char;
i,j:byte;
data:array[128..255] of char;
previous:array[128..255] of byte;
lzwptr:byte;
t:string;
begin
minilzw_decode:='';
if s<>'' then
begin
lzwptr:=127;
oldc:=s[1];
c:=oldc;
i:=2;
minilzw_decode:=oldc;
while i<=length(s) do
begin
newc:=s[i];
if byte(newc)>lzwptr then
begin
t:=c;
c:=oldc;
end
else
begin
c:=newc;
t:='';
end;
while c>=#128 do
begin
inc(t[0]);
t[length(t)]:=data[byte(c)];
byte(c):=previous[byte(c)];
end;
inc(minilzw_decode[0]);
minilzw_decode[length(minilzw_decode)]:=c;
for j:=length(t) downto 1 do
begin
inc(minilzw_decode[0]);
minilzw_decode[length(minilzw_decode)]:=t[j];
end;
if lzwptr=255 then
lzwptr:=127
else
begin
inc(lzwptr);
previous[lzwptr]:=byte(oldc);
data[lzwptr]:=c;
end;
oldc:=newc;
inc(i);
end;
end;
end;
initialization
initupperlower;
end.
{
$Log$
Revision 1.29 2003-10-31 15:51:11 peter
Revision 1.30 2004-01-11 23:56:19 daniel
* Experiment: Compress strings to save memory
Did not save a single byte of mem; clearly the core size is boosted by
temporary memory usage...
Revision 1.29 2003/10/31 15:51:11 peter
* USEINLINE directive added (not enabled yet)
Revision 1.28 2003/09/03 15:55:00 peter
@ -915,5 +1046,4 @@ end.
Revision 1.14 2002/04/12 17:16:35 carl
+ more documentation of basic unit
}
}

13
compiler/ncal.pas
View File

@ -1317,7 +1317,11 @@ type
begin
if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then
begin
srprocsym:=tprocsym(srsymtable.speedsearch(symtableprocentry.name,symtableprocentry.speedvalue));
{$ifdef compress}
srprocsym:=tprocsym(srsymtable.speedsearch(minilzw_encode(symtableprocentry.name),symtableprocentry.speedvalue));
{$else}
srprocsym:=tprocsym(srsymtable.speedsearch(minilzw_encode(symtableprocentry.name),symtableprocentry.speedvalue));
{$endif}
{ process only visible procsyms }
if assigned(srprocsym) and
(srprocsym.typ=procsym) and
@ -2702,7 +2706,12 @@ begin
end.
{
$Log$
Revision 1.217 2003-12-28 22:09:12 florian
Revision 1.218 2004-01-11 23:56:19 daniel
* Experiment: Compress strings to save memory
Did not save a single byte of mem; clearly the core size is boosted by
temporary memory usage...
Revision 1.217 2003/12/28 22:09:12 florian
+ setting of bit 6 of cr for c var args on ppc implemented
Revision 1.216 2003/12/21 19:42:42 florian

21
compiler/symbase.pas
View File

@ -283,9 +283,17 @@ implementation
function tsymtable.search(const s : stringid) : tsymentry;
begin
search:=speedsearch(s,getspeedvalue(s));
end;
var senc:string;
begin
{$ifdef compress}
senc:=minilzw_encode(s);
search:=speedsearch(senc,getspeedvalue(senc));
{$else}
search:=speedsearch(s,getspeedvalue(s));
{$endif}
end;
function tsymtable.speedsearch(const s : stringid;speedvalue : cardinal) : tsymentry;
@ -333,7 +341,12 @@ implementation
end.
{
$Log$
Revision 1.16 2003-12-01 18:44:15 peter
Revision 1.17 2004-01-11 23:56:20 daniel
* Experiment: Compress strings to save memory
Did not save a single byte of mem; clearly the core size is boosted by
temporary memory usage...
Revision 1.16 2003/12/01 18:44:15 peter
* fixed some crashes
* fixed varargs and register calling probs

42
compiler/symdef.pas
View File

@ -3769,7 +3769,7 @@ implementation
ppufile.do_interface_crc:=oldintfcrc;
ppufile.putbyte(byte(has_mangledname));
if has_mangledname then
ppufile.putstring(mangledname);
ppufile.putstring(_mangledname^);
ppufile.putword(overloadnumber);
ppufile.putword(extnumber);
ppufile.putbyte(parast.symtablelevel);
@ -4282,29 +4282,35 @@ implementation
function tprocdef.mangledname : string;
var
s : string;
hp : TParaItem;
begin
if assigned(_mangledname) then
begin
{$ifdef compress}
mangledname:=minilzw_decode(_mangledname^);
{$else}
mangledname:=_mangledname^;
{$endif}
exit;
end;
{ we need to use the symtable where the procsym is inserted,
because that is visible to the world }
s:=make_mangledname('',procsym.owner,procsym.name);
mangledname:=make_mangledname('',procsym.owner,procsym.name);
if overloadnumber>0 then
s:=s+'$'+tostr(overloadnumber);
mangledname:=mangledname+'$'+tostr(overloadnumber);
{ add parameter types }
hp:=TParaItem(Para.first);
while assigned(hp) do
begin
if not hp.is_hidden then
s:=s+'$'+hp.paratype.def.mangledparaname;
mangledname:=mangledname+'$'+hp.paratype.def.mangledparaname;
hp:=TParaItem(hp.next);
end;
_mangledname:=stringdup(s);
mangledname:=_mangledname^;
{$ifdef compress}
_mangledname:=stringdup(minilzw_encode(mangledname));
{$else}
_mangledname:=stringdup(mangledname);
{$endif}
end;
@ -4381,7 +4387,11 @@ implementation
procedure tprocdef.setmangledname(const s : string);
begin
stringdispose(_mangledname);
{$ifdef compress}
_mangledname:=stringdup(minilzw_encode(s));
{$else}
_mangledname:=stringdup(s);
{$endif}
has_mangledname:=true;
end;
@ -5249,7 +5259,7 @@ implementation
end;
procedure tobjectdef.concatstabto(asmlist : taasmoutput);
var st : pstring;
var st:string;
begin
if objecttype<>odt_class then
begin
@ -5270,15 +5280,12 @@ implementation
is_def_stab_written:=not_written;
if assigned(typesym) then
begin
st:=typesym.FName;
typesym.FName:=stringdup(' ');
st:=typesym.name;
typesym.name:=' ';
end;
inherited concatstabto(asmlist);
if assigned(typesym) then
begin
stringdispose(typesym.FName);
typesym.FName:=st;
end;
typesym.name:=st;
end;
end;
{$endif GDB}
@ -6156,7 +6163,12 @@ implementation
end.
{
$Log$
Revision 1.197 2004-01-04 21:10:04 jonas
Revision 1.198 2004-01-11 23:56:20 daniel
* Experiment: Compress strings to save memory
Did not save a single byte of mem; clearly the core size is boosted by
temporary memory usage...
Revision 1.197 2004/01/04 21:10:04 jonas
* Darwin's assembler assumes that all labels starting with 'L' are local
-> rename symbols starting with 'L'

40
compiler/symsym.pas
View File

@ -623,7 +623,11 @@ implementation
if not assigned(_mangledname) then
internalerror(200204171);
end;
{$ifdef compress}
mangledname:=minilzw_decode(_mangledname^)
{$else}
mangledname:=_mangledname^
{$endif}
end;
@ -663,9 +667,14 @@ implementation
procedure tlabelsym.generate_mangledname;
begin
_mangledname:=stringdup(lab.name);
end;
begin
{$ifdef compress}
_mangledname:=stringdup(minilzw_encode(lab.name));
{$else}
_mangledname:=stringdup(lab.name);
{$endif}
end;
procedure tlabelsym.ppuwrite(ppufile:tcompilerppufile);
@ -1645,7 +1654,11 @@ implementation
begin
tvarsym(self).create(n,vsp,tt);
stringdispose(_mangledname);
{$ifdef compress}
_mangledname:=stringdup(minilzw_encode(mangled));
{$else}
_mangledname:=stringdup(mangled);
{$endif}
end;
@ -1700,21 +1713,29 @@ implementation
hvo:=varoptions-[vo_regable,vo_fpuregable];
ppufile.putsmallset(hvo);
if (vo_is_C_var in varoptions) then
ppufile.putstring(mangledname);
ppufile.putstring(_mangledname^);
ppufile.writeentry(ibvarsym);
end;
procedure tvarsym.generate_mangledname;
begin
{$ifdef compress}
_mangledname:=stringdup(minilzw_encode(make_mangledname('U',owner,name)));
{$else}
_mangledname:=stringdup(make_mangledname('U',owner,name));
{$endif}
end;
procedure tvarsym.set_mangledname(const s:string);
begin
stringdispose(_mangledname);
{$ifdef compress}
_mangledname:=stringdup(minilzw_encode(s));
{$else}
_mangledname:=stringdup(s);
{$endif}
end;
@ -2002,7 +2023,11 @@ implementation
procedure ttypedconstsym.generate_mangledname;
begin
{$ifdef compress}
_mangledname:=stringdup(make_mangledname('TC',owner,name));
{$else}
_mangledname:=stringdup(make_mangledname('TC',owner,name));
{$endif}
end;
@ -2689,7 +2714,12 @@ implementation
end.
{
$Log$
Revision 1.140 2004-01-06 15:46:12 peter
Revision 1.141 2004-01-11 23:56:20 daniel
* Experiment: Compress strings to save memory
Did not save a single byte of mem; clearly the core size is boosted by
temporary memory usage...
Revision 1.140 2004/01/06 15:46:12 peter
* fix stabs for locals
Revision 1.139 2003/12/23 22:13:26 peter

67
compiler/symtable.pas
View File

@ -1793,12 +1793,20 @@ implementation
function searchsym(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
var
speedvalue : cardinal;
{$ifdef compress}
senc:stringid;
{$else}
senc:stringid absolute s;
{$endif}
begin
speedvalue:=getspeedvalue(s);
{$ifdef compress}
senc:=minilzw_encode(s);
{$endif}
speedvalue:=getspeedvalue(senc);
srsymtable:=symtablestack;
while assigned(srsymtable) do
begin
srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
srsym:=tsym(srsymtable.speedsearch(senc,speedvalue));
if assigned(srsym) and
(not assigned(current_procinfo) or
tstoredsym(srsym).is_visible_for_object(current_procinfo.procdef._class)) then
@ -1816,8 +1824,16 @@ implementation
function searchsym_type(const s : stringid;var srsym:tsym;var srsymtable:tsymtable):boolean;
var
speedvalue : cardinal;
{$ifdef compress}
senc:stringid;
{$else}
senc:stringid absolute s;
{$endif}
begin
speedvalue:=getspeedvalue(s);
{$ifdef compress}
senc:=minilzw_encode(s);
{$endif}
speedvalue:=getspeedvalue(senc);
srsymtable:=symtablestack;
while assigned(srsymtable) do
begin
@ -1829,7 +1845,7 @@ implementation
}
if not(srsymtable.symtabletype in [recordsymtable,objectsymtable,parasymtable]) then
begin
srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
srsym:=tsym(srsymtable.speedsearch(senc,speedvalue));
if assigned(srsym) and
(not assigned(current_procinfo) or
tstoredsym(srsym).is_visible_for_object(current_procinfo.procdef._class)) then
@ -1877,8 +1893,16 @@ implementation
speedvalue : cardinal;
topclassh : tobjectdef;
sym : tsym;
{$ifdef compress}
senc:stringid;
{$else}
senc:stringid absolute s;
{$endif}
begin
speedvalue:=getspeedvalue(s);
{$ifdef compress}
senc:=minilzw_encode(s);
{$endif}
speedvalue:=getspeedvalue(senc);
{ when the class passed is defined in this unit we
need to use the scope of that class. This is a trick
that can be used to access protected members in other
@ -1897,7 +1921,7 @@ implementation
sym:=nil;
while assigned(classh) do
begin
sym:=tsym(classh.symtable.speedsearch(s,speedvalue));
sym:=tsym(classh.symtable.speedsearch(senc,speedvalue));
if assigned(sym) and
tstoredsym(sym).is_visible_for_object(topclassh) then
break;
@ -2043,11 +2067,19 @@ implementation
var
speedvalue : cardinal;
srsym : tsym;
{$ifdef compress}
senc:string;
{$else}
senc:string absolute s;
{$endif}
begin
speedvalue:=getspeedvalue(s);
{$ifdef compress}
senc:=minilzw_encode(s);
{$endif}
speedvalue:=getspeedvalue(senc);
while assigned(pd) do
begin
srsym:=tsym(pd.symtable.speedsearch(s,speedvalue));
srsym:=tsym(pd.symtable.speedsearch(senc,speedvalue));
if assigned(srsym) then
begin
search_class_member:=srsym;
@ -2108,7 +2140,7 @@ implementation
var
speedvalue : cardinal;
srsym : tprocsym;
s : string;
senc : string;
objdef : tobjectdef;
begin
if aprocsym.overloadchecked then
@ -2121,11 +2153,15 @@ implementation
if not assigned(objdef.childof) then
exit;
objdef:=objdef.childof;
s:=aprocsym.name;
speedvalue:=getspeedvalue(s);
{$ifdef compress}
senc:=minilzw_encode(aprocsym.name);
{$else}
senc:=aprocsym.name;
{$endif}
speedvalue:=getspeedvalue(senc);
while assigned(objdef) do
begin
srsym:=tprocsym(objdef.symtable.speedsearch(s,speedvalue));
srsym:=tprocsym(objdef.symtable.speedsearch(senc,speedvalue));
if assigned(srsym) then
begin
if (srsym.typ<>procsym) then
@ -2298,7 +2334,12 @@ implementation
end.
{
$Log$
Revision 1.123 2003-11-10 22:02:52 peter
Revision 1.124 2004-01-11 23:56:20 daniel
* Experiment: Compress strings to save memory
Did not save a single byte of mem; clearly the core size is boosted by
temporary memory usage...
Revision 1.123 2003/11/10 22:02:52 peter
* cross unit inlining fixed
Revision 1.122 2003/11/08 17:08:44 florian