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

+ support for <dyn. array>+<dyn. array>, resolves #30463

Browse Source 
git-svn-id: trunk@38406 -
This commit is contained in:
florian 2018-03-04 16:12:43 +00:00
parent f0042a4719
commit c230f81719
8 changed files with 370 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -15873,6 +15873,7 @@ tests/webtbs/tw3041.pp svneol=native#text/plain
tests/webtbs/tw30431.pp svneol=native#text/plain
tests/webtbs/tw30443.pp svneol=native#text/plain
tests/webtbs/tw3045.pp svneol=native#text/plain
tests/webtbs/tw30463.pp svneol=native#text/pascal
tests/webtbs/tw3048.pp svneol=native#text/plain
tests/webtbs/tw30498.pp svneol=native#text/pascal
tests/webtbs/tw30522.pp svneol=native#text/plain

7
compiler/htypechk.pas
View File

@ -499,6 +499,13 @@ implementation
exit;
end;
{ <dyn. array> + <dyn. array> is handled by the compiler }
if (treetyp=addn) and (is_dynamic_array(ld) or is_dynamic_array(rd)) then
begin
allowed:=false;
exit;
end;
allowed:=true;
end;
objectdef :

128
compiler/nadd.pas
View File

@ -56,6 +56,7 @@ interface
{ parts explicitely in the code generator (JM) }
function first_addstring: tnode; virtual;
function first_addset: tnode; virtual;
function first_adddynarray : tnode; virtual;
{ only implements "muln" nodes, the rest always has to be done in }
{ the code generator for performance reasons (JM) }
function first_add64bitint: tnode; virtual;
@ -1236,12 +1237,12 @@ implementation
{ convert array constructors to sets, because there is no other operator
possible for array constructors }
if is_array_constructor(left.resultdef) then
if not(is_dynamic_array(right.resultdef)) and is_array_constructor(left.resultdef) then
begin
arrayconstructor_to_set(left);
typecheckpass(left);
end;
if is_array_constructor(right.resultdef) then
if not(is_dynamic_array(left.resultdef)) and is_array_constructor(right.resultdef) then
begin
arrayconstructor_to_set(right);
typecheckpass(right);
@ -2120,7 +2121,16 @@ implementation
inserttypeconv_explicit(right,left.resultdef)
end
{ support dynamicarray=nil,dynamicarray<>nil }
{ <dyn. array>+<dyn. array> ? }
else if (nodetype=addn) and (is_dynamic_array(ld) or is_dynamic_array(rd)) then
begin
if not(is_dynamic_array(ld)) then
inserttypeconv(left,rd);
if not(is_dynamic_array(rd)) then
inserttypeconv(right,ld);
end
{ support dynamicarray=nil,dynamicarray<>nil }
else if (is_dynamic_array(ld) and (rt=niln)) or
(is_dynamic_array(rd) and (lt=niln)) or
(is_dynamic_array(ld) and is_dynamic_array(rd)) then
@ -2729,6 +2739,104 @@ implementation
end;
end;
function taddnode.first_adddynarray : tnode;
var
p: tnode;
newstatement : tstatementnode;
tempnode (*,tempnode2*) : ttempcreatenode;
cmpfuncname: string;
para: tcallparanode;
begin
result:=nil;
{ when we get here, we are sure that both the left and the right }
{ node are both strings of the same stringtype (JM) }
case nodetype of
addn:
begin
if (left.nodetype=arrayconstructorn) and (tarrayconstructornode(left).isempty) then
begin
result:=right;
left.free;
left:=nil;
right:=nil;
exit;
end;
if (right.nodetype=arrayconstructorn) and (tarrayconstructornode(right).isempty) then
begin
result:=left;
left:=nil;
right.free;
right:=nil;
exit;
end;
{ create the call to the concat routine both strings as arguments }
if assigned(aktassignmentnode) and
(aktassignmentnode.right=self) and
(aktassignmentnode.left.resultdef=resultdef) and
valid_for_var(aktassignmentnode.left,false) then
begin
para:=ccallparanode.create(
ctypeconvnode.create_internal(right,voidcodepointertype),
ccallparanode.create(
ctypeconvnode.create_internal(left,voidcodepointertype),
ccallparanode.create(
caddrnode.create_internal(crttinode.create(tstoreddef(resultdef),initrtti,rdt_normal)),
ccallparanode.create(
ctypeconvnode.create_internal(aktassignmentnode.left.getcopy,voidcodepointertype),nil)
)));
result:=ccallnode.createintern(
'fpc_dynarray_concat',
para
);
include(aktassignmentnode.flags,nf_assign_done_in_right);
firstpass(result);
end
else
begin
result:=internalstatements(newstatement);
tempnode:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
addstatement(newstatement,tempnode);
{ initialize the temp, since it will be passed to a
var-parameter (and finalization, which is performed by the
ttempcreate node and which takes care of the initialization
on native targets, is a noop on managed VM targets) }
if (target_info.system in systems_managed_vm) and
is_managed_type(resultdef) then
addstatement(newstatement,cinlinenode.create(in_setlength_x,
false,
ccallparanode.create(genintconstnode(0),
ccallparanode.create(ctemprefnode.create(tempnode),nil))));
para:=ccallparanode.create(
ctypeconvnode.create_internal(right,voidcodepointertype),
ccallparanode.create(
ctypeconvnode.create_internal(left,voidcodepointertype),
ccallparanode.create(
caddrnode.create_internal(crttinode.create(tstoreddef(resultdef),initrtti,rdt_normal)),
ccallparanode.create(
ctypeconvnode.create_internal(ctemprefnode.create(tempnode),voidcodepointertype),nil)
)));
addstatement(
newstatement,
ccallnode.createintern(
'fpc_dynarray_concat',
para
)
);
addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
addstatement(newstatement,ctemprefnode.create(tempnode));
end;
{ we reused the arguments }
left := nil;
right := nil;
end;
unequaln,equaln:
{ nothing to do }
;
else
Internalerror(2018030301);
end;
end;
function taddnode.use_generic_mul32to64: boolean;
begin
@ -3218,6 +3326,15 @@ implementation
exit;
end;
{ Can we optimize multiple dyn. array additions into a single call?
This need to be done on a complete tree to detect the multiple
add nodes and is therefor done before the subtrees are processed }
if canbemultidynarrayadd(self) then
begin
result:=genmultidynarrayadd(self);
exit;
end;
{ typical set tests like (s*[const. set])<>/=[] can be converted into an or'ed chain of in tests
for var sets if const. set contains only a few elements }
if (cs_opt_level1 in current_settings.optimizerswitches) and (nodetype in [unequaln,equaln]) and (left.resultdef.typ=setdef) and not(is_smallset(left.resultdef)) then
@ -3581,6 +3698,11 @@ implementation
end
{$endif SUPPORT_MMX}
else if is_dynamic_array(ld) or is_dynamic_array(rd) then
begin
result:=first_adddynarray;
exit;
end
{ the general solution is to convert to 32 bit int }
else
begin

7
compiler/nld.pas
View File

@ -121,6 +121,7 @@ interface
function docompare(p: tnode): boolean; override;
procedure force_type(def:tdef);
procedure insert_typeconvs;
function isempty : boolean;
end;
tarrayconstructornodeclass = class of tarrayconstructornode;
@ -1016,6 +1017,12 @@ implementation
end;
function tarrayconstructornode.isempty:boolean;
begin
result:=not(assigned(left)) and not(assigned(right));
end;
function tarrayconstructornode.pass_typecheck:tnode;
var
hdef : tdef;

93
compiler/nopt.pas
View File

@ -76,6 +76,8 @@ function canbeaddsstringcsstringoptnode(p: taddnode): boolean;
function genaddsstringcsstringoptnode(p: taddnode): tnode;
function canbemultistringadd(p: taddnode): boolean;
function genmultistringadd(p: taddnode): tnode;
function canbemultidynarrayadd(p: taddnode): boolean;
function genmultidynarrayadd(p: taddnode): tnode;
function is_addsstringoptnode(p: tnode): boolean;
@ -406,6 +408,97 @@ begin
end;
end;
function canbemultidynarrayadd(p: taddnode): boolean;
var
hp : tnode;
i : longint;
begin
result:=false;
if not(is_dynamic_array(p.resultdef)) then
exit;
i:=0;
hp:=p;
while assigned(hp) and (hp.nodetype=addn) do
begin
inc(i);
hp:=taddnode(hp).left;
end;
result:=(i>1);
end;
function genmultidynarrayadd(p: taddnode): tnode;
var
hp,sn : tnode;
arrp : tarrayconstructornode;
newstatement : tstatementnode;
tempnode : ttempcreatenode;
para : tcallparanode;
begin
arrp:=nil;
hp:=p;
while assigned(hp) and (hp.nodetype=addn) do
begin
sn:=ctypeconvnode.create_internal(taddnode(hp).right.getcopy,voidpointertype);
arrp:=carrayconstructornode.create(sn,arrp);
hp:=taddnode(hp).left;
end;
sn:=ctypeconvnode.create_internal(hp.getcopy,voidpointertype);
arrp:=carrayconstructornode.create(sn,arrp);
arrp.allow_array_constructor:=true;
if assigned(aktassignmentnode) and
(aktassignmentnode.right=p) and
(aktassignmentnode.left.resultdef=p.resultdef) and
valid_for_var(aktassignmentnode.left,false) then
begin
para:=ccallparanode.create(
arrp,
ccallparanode.create(
caddrnode.create_internal(crttinode.create(tstoreddef(p.resultdef),initrtti,rdt_normal)),
ccallparanode.create(
ctypeconvnode.create_internal(aktassignmentnode.left.getcopy,voidpointertype),nil)
));
result:=ccallnode.createintern(
'fpc_dynarray_concat_multi',
para
);
include(aktassignmentnode.flags,nf_assign_done_in_right);
end
else
begin
result:=internalstatements(newstatement);
tempnode:=ctempcreatenode.create(p.resultdef,p.resultdef.size,tt_persistent ,true);
addstatement(newstatement,tempnode);
{ initialize the temp, since it will be passed to a
var-parameter (and finalization, which is performed by the
ttempcreate node and which takes care of the initialization
on native targets, is a noop on managed VM targets) }
if (target_info.system in systems_managed_vm) and
is_managed_type(p.resultdef) then
addstatement(newstatement,cinlinenode.create(in_setlength_x,
false,
ccallparanode.create(genintconstnode(0),
ccallparanode.create(ctemprefnode.create(tempnode),nil))));
para:=ccallparanode.create(
arrp,
ccallparanode.create(
caddrnode.create_internal(crttinode.create(tstoreddef(p.resultdef),initrtti,rdt_normal)),
ccallparanode.create(
ctypeconvnode.create_internal(ctemprefnode.create(tempnode),voidpointertype),nil)
));
addstatement(
newstatement,
ccallnode.createintern(
'fpc_dynarray_concat_multi',
para
)
);
addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
addstatement(newstatement,ctemprefnode.create(tempnode));
end;
end;
begin
caddsstringcharoptnode := taddsstringcharoptnode;
caddsstringcsstringoptnode := taddsstringcsstringoptnode;

1
rtl/inc/compproc.inc
View File

@ -81,6 +81,7 @@ procedure fpc_dynarray_assign(var dest : pointer; src : pointer; ti: pointer); c
procedure fpc_dynarray_delete(var p : pointer;source,count : SizeInt;pti : pointer);compilerproc;
procedure fpc_dynarray_insert(var p : pointer;source : SizeInt;data : pointer;count : SizeInt;pti : pointer);compilerproc;
procedure fpc_dynarray_concat_multi(var dest : pointer; pti: pointer; const sarr:array of pointer); compilerproc;
procedure fpc_dynarray_concat(var dest : pointer; pti: pointer; const src1,src2 : pointer); compilerproc;
{$endif VER3_0}
{$endif FPC_HAS_FEATURE_DYNARRAYS}

116
rtl/inc/dynarr.inc
View File

@ -401,11 +401,7 @@ procedure fpc_dynarray_delete(var p : pointer;source,count : SizeInt;pti : point
end;
{ skip kind and name }
{$ifdef VER3_0}
ti:=aligntoptr(Pointer(pti)+2+PByte(pti)[1]);
{$else VER3_0}
ti:=aligntoqword(Pointer(pti)+2+PByte(pti)[1]);
{$endif VER3_0}
elesize:=pdynarraytypedata(ti)^.elSize;
eletype:=pdynarraytypedata(ti)^.elType2^;
@ -468,6 +464,7 @@ procedure fpc_dynarray_delete(var p : pointer;source,count : SizeInt;pti : point
newp^.high:=newhigh;
end;
procedure fpc_dynarray_insert(var p : pointer;source : SizeInt;data : pointer;count : SizeInt;pti : pointer);compilerproc;
var
newhigh,
@ -501,11 +498,7 @@ procedure fpc_dynarray_insert(var p : pointer;source : SizeInt;data : pointer;co
source:=0;
{ skip kind and name }
{$ifdef VER3_0}
ti:=aligntoptr(Pointer(pti)+2+PByte(pti)[1]);
{$else VER3_0}
ti:=aligntoqword(Pointer(pti)+2+PByte(pti)[1]);
{$endif VER3_0}
elesize:=pdynarraytypedata(ti)^.elSize;
eletype:=pdynarraytypedata(ti)^.elType2^;
@ -600,6 +593,7 @@ procedure fpc_dynarray_insert(var p : pointer;source : SizeInt;data : pointer;co
newp^.high:=newhigh;
end;
procedure fpc_dynarray_concat_multi(var dest : pointer; pti: pointer; const sarr:array of pointer); compilerproc;
var
i,
@ -610,11 +604,8 @@ procedure fpc_dynarray_concat_multi(var dest : pointer; pti: pointer; const sarr
srealp : pdynarray;
ti : pointer;
elesize : sizeint;
{eletype,}eletypemngd : pointer;
eletypemngd : pointer;
begin
{ the destination is overwritten in each case, so clear it }
fpc_dynarray_clear(dest,pti);
{ sanity check }
if length(sarr)=0 then
exit;
@ -622,35 +613,33 @@ procedure fpc_dynarray_concat_multi(var dest : pointer; pti: pointer; const sarr
totallen:=0;
for i:=0 to high(sarr) do
if assigned(sarr[i]) then
begin
srealp:=pdynarray(sarr[i]-sizeof(tdynarray));
inc(totallen,srealp^.high+1);
end;
inc(totallen,pdynarray(sarr[i]-sizeof(tdynarray))^.high+1);
if totallen=0 then
exit;
begin
fpc_dynarray_clear(dest,pti);
exit;
end;
{ skip kind and name }
{$ifdef VER3_0}
ti:=aligntoptr(Pointer(pti)+2+PByte(pti)[1]);
{$else VER3_0}
ti:=aligntoqword(Pointer(pti)+2+PByte(pti)[1]);
{$endif VER3_0}
elesize:=pdynarraytypedata(ti)^.elSize;
//eletype:=pdynarraytypedata(ti)^.elType2^;
{ only set if type needs initialization }
if assigned(pdynarraytypedata(ti)^.elType) then
eletypemngd:=pdynarraytypedata(ti)^.elType^
else
eletypemngd:=nil;
{ allocate new array }
getmem(newp,totallen*elesize+sizeof(tdynarray));
fillchar(newp^,sizeof(tdynarray),0);
{ copy the elements of each source array }
offset:=0;
{ the idea to reuse the first array, re-allocate it and append the other entries is not possible as the first entry
might be finalized later on by the caller however in case of a re-allocate, the entry itself might be gone }
{ allocate new array }
getmem(newp,totallen*elesize+sizeof(tdynarray));
for i:=0 to high(sarr) do
if assigned(sarr[i]) then
begin
@ -661,6 +650,79 @@ procedure fpc_dynarray_concat_multi(var dest : pointer; pti: pointer; const sarr
inc(offset,srealp^.high+1);
end;
end;
{ increase reference counts of all the elements }
if assigned(eletypemngd) then
begin
for i:=0 to totallen-1 do
int_addref(pointer(newp)+sizeof(tdynarray)+i*elesize,eletypemngd);
end;
{ clear at the end, dest could be a reference to an array being used also as source }
fpc_dynarray_clear(dest,pti);
dest:=pointer(newp)+sizeof(tdynarray);
newp^.refcount:=1;
newp^.high:=totallen-1;
end;
procedure fpc_dynarray_concat(var dest : pointer; pti: pointer; const src1,src2 : pointer); compilerproc;
var
i,
offset,
totallen : sizeint;
newp,
realp,
srealp : pdynarray;
ti : pointer;
elesize : sizeint;
eletypemngd : pointer;
begin
totallen:=0;
if assigned(src1) then
inc(totallen,pdynarray(src1-sizeof(tdynarray))^.high+1);
if assigned(src2) then
inc(totallen,pdynarray(src2-sizeof(tdynarray))^.high+1);
if totallen=0 then
begin
fpc_dynarray_clear(dest,pti);
exit;
end;
{ skip kind and name }
ti:=aligntoqword(Pointer(pti)+2+PByte(pti)[1]);
elesize:=pdynarraytypedata(ti)^.elSize;
{ only set if type needs initialization }
if assigned(pdynarraytypedata(ti)^.elType) then
eletypemngd:=pdynarraytypedata(ti)^.elType^
else
eletypemngd:=nil;
{ the idea to reuse the first array, re-allocate it and append the other entries is not possible as the first entry
might be finalized later on by the caller however in case of a re-allocate, the entry itself might be gone }
{ allocate new array }
getmem(newp,totallen*elesize+sizeof(tdynarray));
{ copy the elements of each source array }
offset:=0;
if assigned(src1) then
begin
srealp:=pdynarray(src1-sizeof(tdynarray));
if srealp^.high>=0 then
begin
move(src1^,(pointer(newp)+sizeof(tdynarray)+offset*elesize)^,(srealp^.high+1)*elesize);
inc(offset,srealp^.high+1);
end;
end;
if assigned(src2) then
begin
srealp:=pdynarray(src2-sizeof(tdynarray));
if srealp^.high>=0 then
move(src2^,(pointer(newp)+sizeof(tdynarray)+offset*elesize)^,(srealp^.high+1)*elesize);
end;
{ increase reference counts of all the elements }
if assigned(eletypemngd) then
@ -669,6 +731,8 @@ procedure fpc_dynarray_concat_multi(var dest : pointer; pti: pointer; const sarr
int_addref(pointer(newp)+sizeof(tdynarray)+i*elesize,eletypemngd);
end;
{ clear at the end, dest could be a reference to an array being also source }
fpc_dynarray_clear(dest,pti);
dest:=pointer(newp)+sizeof(tdynarray);
newp^.refcount:=1;
newp^.high:=totallen-1;

46
tests/webtbs/tw30463.pp Normal file
View File

@ -0,0 +1,46 @@
{$mode objfpc}
procedure p1;
var
A: array of Integer;
i: integer;
begin
A := [];
A := A + A;
A := Concat(A,[123456789]);
A := A + [6];
A := A + A;
if A[0]<>123456789 then
Halt(1);
if A[High(A)]<>6 then
Halt(1);
end;
procedure p2;
var
A, B, C: array of Integer;
i: integer;
begin
A := [];
A := A + A + A;
A := Concat(A,[123456789],[8]);
A := A + [6] + A;
A := A + A + A;
B:=copy(A);
C:=B+A;
if C[0]<>123456789 then
Halt(1);
if C[High(C)]<>8 then
Halt(1);
if C[High(C)-1]<>123456789 then
Halt(1);
end;
begin
// p1;
p2;
writeln('ok');
end.