Let fpc_dynarray_concat(_multi) reuse the only nonempty input or append to the destination if possible.

Improve fpc_dynarray_delete.

rtl/inc/dynarr.inc

@@ -391,69 +391,56 @@ function fpc_array_to_dynarray_copy(psrc : pointer;ti : pointer;
 {$ifndef VER3_0}
 procedure fpc_dynarray_delete(var p : pointer;source,count : SizeInt;pti : pointer);
    var
-      newhigh : tdynarrayindex;
-      size : sizeint;
-      { contains the "fixed" pointers where the refcount }
-      { and high are at positive offsets                 }
-      realp,newp : pdynarray;
-      ti : pointer;
+      newlen : tdynarrayindex;
       elesize : sizeint;
-      eletype,eletypemngd : pointer;
+      { oldp is the same as p, actual header is accessed as oldp[-1].
+        newp fairly points to the new header, array data starts at newp[1].
+        realp takes the hit of being a var-parameter to ReallocMem not eligible for living in a register. }
+      oldp,newp,realp : pdynarray;
+      ti,eletypemngd : pointer;
 
    begin
-     { if source > high then nothing to do }
-     if not assigned(p) or
-         (source>pdynarray(p-sizeof(tdynarray))^.high) or
-         (count<=0) or
-         (source<0) then
+     oldp:=p;
+     if not assigned(oldp) or (count<=0) then
        exit;
-     { cap count }
-     if source+count-1>pdynarray(p-sizeof(tdynarray))^.high then
-       count:=pdynarray(p-sizeof(tdynarray))^.high-source+1;
-
-     { fast path: delete whole array }
-     if (source=0) and (count=pdynarray(p-sizeof(tdynarray))^.high+1) then
+     newlen:=oldp[-1].high+1;
+     { Checks source < 0 or source >= len, using the fact that len is never negative. }
+     if SizeUint(source)>=SizeUint(newlen) then
+       exit;
+     { cap count, and maybe delete whole array }
+     if count>=newlen-source then
        begin
-         fpc_dynarray_clear(p,pti);
-         exit;
+         if source=0 then
+           begin
+             fpc_dynarray_clear(p,pti);
+             exit;
+           end;
+         count:=newlen-source;
        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 finalization }
-     if assigned(pdynarraytypedata(ti)^.elType) then
-       eletypemngd:=pdynarraytypedata(ti)^.elType^
-     else
-       eletypemngd:=nil;
-
-     realp:=pdynarray(p-sizeof(tdynarray));
-     newp:=realp;
+     eletypemngd:=pdynarraytypedata(ti)^.elType;
+     if assigned(eletypemngd) then
+       eletypemngd:=PPointer(eletypemngd)^;
 
-     { determine new memory size }
-     newhigh:=realp^.high-count;
-     size:=elesize*(newhigh+1)+sizeof(tdynarray);
+     newlen:=newlen-count;
 
-     if realp^.refcount<>1 then
+     if oldp[-1].refcount<>1 then
        begin
           { make an unique copy }
-          getmem(newp,size);
-          fillchar(newp^,sizeof(tdynarray),0);
+          newp:=getmem(elesize*newlen+sizeof(tdynarray));
+          newp^.refcount:=1;
           { copy the elements that we still need }
-          if source>0 then
-            move(p^,(pointer(newp)+sizeof(tdynarray))^,source*elesize);
-          if source+count-1<realp^.high then
-            move((p+(source+count)*elesize)^,(pointer(newp)+sizeof(tdynarray)+source*elesize)^,(realp^.high-(source+count)+1)*elesize);
+          move(oldp^,pointer(newp+1)^,source*elesize);
+          move((pointer(oldp)+(source+count)*elesize)^,(pointer(newp+1)+source*elesize)^,(newlen-source)*elesize);
 
           { increment ref. count of managed members }
           if assigned(eletypemngd) then
-            int_AddRefArray(pointer(newp)+sizeof(tdynarray),eletypemngd,newhigh+1);
+            int_AddRefArray(newp+1,eletypemngd,newlen);
 
           { a declock(ref. count) isn't enough here }
           { it could be that the in MT environments  }
@@ -468,18 +455,17 @@ procedure fpc_dynarray_delete(var p : pointer;source,count : SizeInt;pti : point
         begin
           { finalize the elements that will be removed }
           if assigned(eletypemngd) then
-            int_FinalizeArray(p+source*elesize,eletype,count);
+            int_FinalizeArray(pointer(oldp)+source*elesize,eletypemngd,count);
 
           { close the gap by moving the trailing elements to the front }
-          move((p+(source+count)*elesize)^,(p+source*elesize)^,(realp^.high-(source+count)+1)*elesize);
+          move((pointer(oldp)+(source+count)*elesize)^,(pointer(oldp)+source*elesize)^,(newlen-source)*elesize);
 
           { resize the array }
-          reallocmem(realp,size);
-          newp:=realp;
+          realp:=oldp-1;
+          newp:=reallocmem(realp,elesize*newlen+sizeof(tdynarray));
         end;
-    p:=pointer(newp)+sizeof(tdynarray);
-    newp^.refcount:=1;
-    newp^.high:=newhigh;
+    newp^.high:=newlen-1;
+    p:=newp+1;
   end;
 
 
@@ -586,24 +572,17 @@ procedure fpc_dynarray_insert(var p : pointer;source : SizeInt;data : pointer;co
 
 procedure fpc_dynarray_concat_multi(var dest : pointer; pti: pointer; const sarr:array of pointer); compilerproc;
   var
-    i,
-    offset,
-    totallen : sizeint;
-    newp,
-    realp,
-    srealp : pdynarray;
-    ti : pointer;
-    elesize : sizeint;
-    eletypemngd : pointer;
+    i,firstnonempty,elesize,totallen,copybytes,skip : sizeint;
+    newp,realp,copysrc,olddestp : pdynarray;
+    ti,eletypemngd,copydest : pointer;
   begin
-    { sanity check }
-    if length(sarr)=0 then
-      exit;
-
     totallen:=0;
-    for i:=0 to high(sarr) do
+    for i:=high(sarr) downto 0 do
       if assigned(sarr[i]) then
-        inc(totallen,pdynarray(sarr[i]-sizeof(tdynarray))^.high+1);
+        begin
+          inc(totallen,pdynarray(sarr[i])[-1].high+1);
+          firstnonempty:=i; { 1) allows for append optimization to work even with some prepended []s, 2) required for the reuse optimization. }
+        end;
 
     if totallen=0 then
       begin
@@ -611,122 +590,128 @@ procedure fpc_dynarray_concat_multi(var dest : pointer; pti: pointer; const sarr
         exit;
       end;
 
+    { Reuse the only nonempty input? }
+    if totallen=pdynarray(sarr[firstnonempty])[-1].high+1 then
+      begin
+        fpc_dynarray_assign(dest,sarr[firstnonempty],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}
+    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;
+    eletypemngd:=pdynarraytypedata(ti)^.elType;
+    if Assigned(eletypemngd) then
+      eletypemngd:=PPointer(eletypemngd)^;
 
-    { copy the elements of each source array }
-    offset:=0;
+    { Can append? }
+    olddestp:=dest;
+    if (olddestp=sarr[firstnonempty]) and (olddestp[-1].refcount=1) then
+      begin
+        { Append, and be careful with 'dest' occuring among pieces. }
+        realp:=olddestp-1;
+        newp:=reallocmem(realp,totallen*elesize+sizeof(tdynarray));
+        copydest:=pointer(newp+1)+(newp^.high+1)*elesize;
+        inc(firstnonempty); { Start from the next element. }
+      end
+    else
+      begin
+        olddestp:=nil; { Append case is distinguished later as assigned(olddestp). }
+        { allocate new array }
+        newp:=getmem(totallen*elesize+sizeof(tdynarray));
+        newp^.refcount:=1;
+        copydest:=newp+1;
+      end;
 
-    { 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));
+    while firstnonempty<=high(sarr) do
+      begin
+        copysrc:=sarr[firstnonempty];
+        inc(firstnonempty);
+        if not assigned(copysrc) then
+          continue;
+        if copysrc=olddestp then
+          { Dest used as one of the pieces! Use new pointer instead. Array header still conveniently contains original 'high'.
+            Can trigger only when appending, as otherwise olddestp = nil. }
+          copysrc:=newp+1;
+        copybytes:=(copysrc[-1].high+1)*elesize;
+        move(copysrc^,copydest^,copybytes);
+        inc(copydest,copybytes);
+      end;
 
-    for i:=0 to high(sarr) do
-      if assigned(sarr[i]) then
-        begin
-          srealp:=pdynarray(sarr[i]-sizeof(tdynarray));
-          if srealp^.high>=0 then
-            begin
-              move(sarr[i]^,(pointer(newp)+sizeof(tdynarray)+offset*elesize)^,(srealp^.high+1)*elesize);
-              inc(offset,srealp^.high+1);
-            end;
-        end;
-    { increase reference counts of all the elements }
     if assigned(eletypemngd) then
-      int_AddRefArray(pointer(newp)+sizeof(tdynarray),eletypemngd,totallen);
+      begin
+        skip:=0;
+        if assigned(olddestp) then
+          skip:=newp^.high+1;
+        int_AddRefArray(pointer(newp+1)+skip*elesize,eletypemngd,totallen-skip);
+      end;
+
+    if not assigned(olddestp) then
+      { clear at the end, dest could be a reference to an array being used also as source }
+      fpc_dynarray_clear(dest,pti);
 
-    { 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;
+    dest:=newp+1;
   end;
 
 
 procedure fpc_dynarray_concat(var dest : pointer; pti: pointer; const src1,src2 : pointer); compilerproc;
   var
-    offset,
-    totallen : sizeint;
-    newp,
-    realp,
-    srealp : pdynarray;
-    ti : pointer;
-    elesize : sizeint;
-    eletypemngd : pointer;
+    totallen,elesize,ofs2 : sizeint;
+    newp,realp,olddestp,copysrc : pdynarray;
+    ti,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
+    if not assigned(src1) or not assigned(src2) then
       begin
-        fpc_dynarray_clear(dest,pti);
-        exit;
+        fpc_dynarray_assign(dest, pointer(ptruint(src1) or ptruint(src2)), pti);
+        exit; { From now on, both src1 and src2 are non-nil. }
       end;
+    totallen:=pdynarray(src1)[-1].high+pdynarray(src2)[-1].high+2;
 
     { 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}
+    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));
+    eletypemngd:=pdynarraytypedata(ti)^.elType;
+    if assigned(eletypemngd) then
+      eletypemngd:=PPointer(eletypemngd)^;
 
-    { copy the elements of each source array }
-    offset:=0;
-    if assigned(src1) then
+    olddestp:=dest;
+    { Can append? }
+    if (olddestp=src1) and (olddestp[-1].refcount=1) 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
+        { Append, and be careful with dest = src2. }
+        realp:=olddestp-1;
+        newp:=reallocmem(realp,totallen*elesize+sizeof(tdynarray));
+        copysrc:=src2;
+        if src2=olddestp then
+          { Use new pointer instead. Array header still conveniently contains original 'high'. }
+          copysrc:=newp+1;
+        move(copysrc^,(pointer(newp+1)+(newp^.high+1)*elesize)^,(copysrc[-1].high+1)*elesize);
+        if assigned(eletypemngd) then
+          int_AddRefArray(pointer(newp+1)+(newp^.high+1)*elesize,eletypemngd,copysrc[-1].high+1);
+      end
+    else
       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
-      int_AddRefArray(pointer(newp)+sizeof(tdynarray),eletypemngd,totallen);
+        { allocate new array }
+        newp:=getmem(totallen*elesize+sizeof(tdynarray));
+        newp^.refcount:=1;
+        ofs2:=(pdynarray(src1)[-1].high+1)*elesize;
+        move(src1^,newp[1],ofs2);
+        move(src2^,(pointer(newp+1)+ofs2)^,(pdynarray(src2)[-1].high+1)*elesize);
+
+        { increase reference counts of all the elements }
+        if assigned(eletypemngd) then
+          int_AddRefArray(newp+1,eletypemngd,totallen);
 
-    { 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;
+        { clear at the end, dest could be a reference to an array being also source }
+        fpc_dynarray_clear(dest,pti);
+      end;
     newp^.high:=totallen-1;
+    dest:=newp+1;
   end;
 {$endif VER3_0}
 

tests/test/tarray23.pp

@@ -0,0 +1,157 @@
+{$mode objfpc} {$longstrings on} {$coperators on} {$modeswitch arrayoperators}
+generic procedure SetArray<T>(out a: specialize TArray<T>; const data: array of T);
+begin
+	a := Copy(data);
+end;
+
+generic function ArraysEqual<T>(const a, b: array of T): boolean;
+var
+	i: SizeInt;
+begin
+	if length(a) <> length(b) then exit(false);
+	for i := 0 to High(a) do
+		if a[i] <> b[i] then exit(false);
+	result := true;
+end;
+
+generic function ToString<T>(const a: array of T): string;
+var
+	i: SizeInt;
+	es: string;
+begin
+	result := '(';
+	for i := 0 to High(a) do
+	begin
+		if i > 0 then result += ', ';
+		WriteStr(es, a[i]);
+		result += es;
+	end;
+	result += ')';
+end;
+
+var
+	somethingFailed: boolean = false;
+
+generic function Verify<T>(const a, ref: array of T; const what: string): boolean;
+begin
+	result := specialize ArraysEqual<T>(a, ref);
+	if not result then
+	begin
+		writeln(what + ':' + LineEnding +
+			specialize ToString<T>(a) + ',' + LineEnding +
+			'expected:' + LineEnding +
+			specialize ToString<T>(ref) + '.' + LineEnding);
+		somethingFailed := true;
+	end;
+end;
+
+generic procedure SetConcat<T>(var a: specialize TArray<T>; const p0, p1: specialize TArray<T>);
+begin
+	a := p0 + p1;
+end;
+
+generic procedure SetConcat<T>(var a: specialize TArray<T>; const p0, p1, p2: specialize TArray<T>);
+begin
+	a := p0 + p1 + p2;
+end;
+
+generic procedure Test<T>(const vs: array{[0 .. 5]} of T; const typename: string);
+var
+	a, b, c, d, ref: array of T;
+	preva: pointer;
+	i, tries: int32;
+begin
+	// Back in the day, delete() with huge count could crash, or corrupt some memory and produce an invalid array with negative length.
+	specialize SetArray<T>(a, vs[0 .. 3]);
+	delete(a, 2, High(SizeInt));
+	if length(a) = 2 then
+		specialize Verify<T>(a, vs[0 .. 1], 'delete(' + specialize ToString<T>(vs[0 .. 3]) + ', start = 2, count = High(SizeInt))')
+	else
+	begin
+		writeln('Length after delete(' + specialize ToString<T>(vs[0 .. 3]) + ', start = 2, count = High(SizeInt)) is ', length(a), ', expected 2.', LineEnding);
+		somethingFailed := true;
+	end;
+
+	specialize SetArray<T>(a, vs[0 .. 3]);
+	specialize SetArray<T>(b, [vs[4]]);
+	specialize SetArray<T>(c, [vs[5]]);
+	tries := 0;
+	repeat
+		if tries >= 100 then
+		begin
+			writeln('dynarray_concat_multi(' + typename + ') has no append optimization.', LineEnding);
+			somethingFailed := true;
+			break;
+		end;
+		preva := pointer(a);
+		specialize SetConcat<T>(a, a, b, c);
+
+		ref := Copy(vs, 0, 4);
+		SetLength(ref, 4 + 2 * (1 + tries));
+		for i := 4 to High(ref) do ref[i] := vs[4 + i and 1];
+		inc(tries);
+	until not specialize Verify<T>(a, ref, 'dynarray_concat_multi(' + typename + ')') or (pointer(a) = preva);
+
+	specialize SetArray<T>(a, vs[0 .. 3]);
+	specialize SetArray<T>(b, [vs[4]]);
+	tries := 0;
+	repeat
+		if tries >= 100 then
+		begin
+			writeln('dynarray_concat(' + typename + ') has no append optimization.', LineEnding);
+			somethingFailed := true;
+			break;
+		end;
+		preva := pointer(a);
+		specialize SetConcat<T>(a, a, b);
+
+		ref := Copy(vs, 0, 4);
+		SetLength(ref, 4 + (1 + tries));
+		for i := 4 to High(ref) do ref[i] := vs[4];
+		inc(tries);
+	until not specialize Verify<T>(a, ref, 'dynarray_concat(' + typename + ')') or (pointer(a) = preva);
+
+	specialize SetArray<T>(a, [vs[0]]);
+	specialize SetArray<T>(b, []);
+	specialize SetArray<T>(c, vs[1 .. 2]);
+	specialize SetArray<T>(d, []);
+	specialize SetConcat<T>(a, b, c, d);
+	if specialize Verify<T>(a, vs[1 .. 2], '() + ' + specialize ToString<T>(vs[1 .. 2]) + ' + ()') and (pointer(a) <> pointer(c)) then
+	begin
+		writeln('dynarray_concat_multi(' + typename + ') does not reuse the only nonempty input.', LineEnding);
+		somethingFailed := true;
+	end;
+
+	specialize SetArray<T>(a, [vs[0]]);
+	specialize SetArray<T>(b, vs[1 .. 2]);
+	specialize SetArray<T>(c, []);
+	specialize SetConcat<T>(a, b, c);
+	if specialize Verify<T>(a, vs[1 .. 2], specialize ToString<T>(vs[1 .. 2]) + ' + ()') and (pointer(a) <> pointer(b)) then
+	begin
+		writeln('dynarray_concat(' + typename + ') does not reuse the only nonempty input #1.', LineEnding);
+		somethingFailed := true;
+	end;
+
+	specialize SetArray<T>(a, [vs[0]]);
+	specialize SetArray<T>(b, []);
+	specialize SetArray<T>(c, vs[1 .. 2]);
+	specialize SetConcat<T>(a, b, c);
+	if specialize Verify<T>(a, vs[1 .. 2], '() + ' + specialize ToString<T>(vs[1 .. 2])) and (pointer(a) <> pointer(c)) then
+	begin
+		writeln('dynarray_concat(' + typename + ') does not reuse the only nonempty input #2.', LineEnding);
+		somethingFailed := true;
+	end;
+end;
+
+function CopyStr(const src: string): string;
+begin
+	result := System.Copy(src, 1, length(src));
+end;
+
+begin
+	specialize Test<int32>([1, 2, 3, 4, 5, 6], 'int32');
+	specialize Test<string>([CopyStr('S1'), CopyStr('S2'), CopyStr('S3'), CopyStr('S4'), CopyStr('S5'), CopyStr('S6')], 'string');
+
+	if not somethingFailed then writeln('ok');
+	if somethingFailed then halt(1);
+end.