* Avoid calling copy operator when moving data from temporary objects

When a function returns a managed record, a new temporary object is
created for the result, which is then copied to the real destination.
For managed records with a deep copy implementation, this can create
immense overhead. So instead this introduces a move, which basically
consists of
```pascal
procedure Move(var src, dst);
begin
  Finalize(dst); // Finalize existing data
  Move(src,dst,sizeof(dst)); // Shallow copy
  Initialize(src); // Clear source
```

* nld.pas: use MOVE when assigning the function result from the
  temporary return object
* rtl/inc/systemh.pas: Adding new macro to mark new RTTI version with MOVE
  operation
* rtl/inc/compproc.inc, rtl/inc/rtti.inc: Adding new move mechanism when
  indicated by the compiler.

compiler/nld.pas

@@ -920,6 +920,36 @@ implementation
 
 
     function tassignmentnode.pass_1 : tnode;
+
+      function tempreturnfromcall:boolean;
+        var
+          node:tnode;
+        begin
+          result:=false;
+          if not is_managed_type(right.resultdef) then
+            exit;
+          node:=right;
+          while assigned(node) do
+            begin
+              case node.nodetype of
+              blockn:
+                node:=tblocknode(node).left;
+              statementn:
+                if assigned(tstatementnode(node).right) then
+                  node:=tstatementnode(node).right
+                else
+                  node:=tstatementnode(node).left;
+              else
+                break;
+              end;
+            end;
+          if not assigned(node) then
+            internalerror(2024111101);
+          if (node.nodetype=calln) and assigned(tcallnode(node).funcretnode) then
+            node:=tcallnode(node).funcretnode;
+          result:=(node.nodetype=temprefn) and (nf_is_funcret in node.flags);
+        end;
+
       var
         hp: tnode;
         oldassignmentnode : tassignmentnode;
@@ -986,13 +1016,15 @@ implementation
             not is_const(left) and
             not(target_info.system in systems_garbage_collected_managed_types) then
          begin
-           hp:=ccallparanode.create(caddrnode.create_internal(
+           hp:=ccallparanode.create(cordconstnode.create(
+                  ord(tempreturnfromcall),pasbool1type,false),
+               ccallparanode.create(caddrnode.create_internal(
                   crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
                ccallparanode.create(ctypeconvnode.create_internal(
                  caddrnode.create_internal(left),voidpointertype),
                ccallparanode.create(ctypeconvnode.create_internal(
                  caddrnode.create_internal(right),voidpointertype),
-               nil)));
+               nil))));
            result:=ccallnode.createintern('fpc_copy_proc',hp);
            firstpass(result);
            left:=nil;

rtl/inc/compproc.inc

@@ -736,8 +736,13 @@ procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); compile
 procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); compilerproc;
 procedure fpc_addref_array(data,typeinfo: pointer; count: SizeInt); compilerproc;
 procedure fpc_decref_array(data,typeinfo: pointer; count: sizeint); compilerproc;
+{$ifdef FPC_MANAGED_MOVE}
+Function fpc_Copy (Src, Dest, TypeInfo : Pointer; DoMove : Boolean) : SizeInt; compilerproc;
+Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer; DoMove : Boolean); compilerproc; inline;
+{$else}
 Function fpc_Copy (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc;
 Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
+{$endif FPC_MANAGED_MOVE}
 {$endif FPC_HAS_FEATURE_RTTI}
 
 

rtl/inc/rtti.inc

@@ -249,11 +249,17 @@ begin
   end;
 end;
 
+{$ifdef FPC_MANAGED_MOVE}
+{ define alias for internal use in the system unit }
+Function fpc_Copy_internal (Src, Dest, TypeInfo : Pointer; DoMove : Boolean) : SizeInt;[external name 'FPC_COPY'];
 
+Function fpc_Copy (Src, Dest, TypeInfo : Pointer; DoMove : Boolean) : SizeInt;[Public,alias : 'FPC_COPY']; compilerproc;
+{$else}
 { define alias for internal use in the system unit }
 Function fpc_Copy_internal (Src, Dest, TypeInfo : Pointer) : SizeInt;[external name 'FPC_COPY'];
 
 Function fpc_Copy (Src, Dest, TypeInfo : Pointer) : SizeInt;[Public,alias : 'FPC_COPY']; compilerproc;
+{$endif FPC_MANAGED_MOVE}
 var
   copiedsize,
   expectedoffset,
@@ -267,14 +273,41 @@ begin
   case PTypeKind(TypeInfo)^ of
 {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
     tkAstring:
+{$ifdef FPC_MANAGED_MOVE}
+      if domove then
+        begin
+          fpc_AnsiStr_Decr_Ref(PPointer(Dest)^);
+          PPointer(Dest)^:=PPointer(src)^;
+          PPointer(Src)^:=nil;
+        end
+      else
+{$endif FPC_MANAGED_MOVE}
       fpc_AnsiStr_Assign(PPointer(Dest)^,PPointer(Src)^);
 {$endif FPC_HAS_FEATURE_ANSISTRINGS}
 {$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
   {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
     tkWstring:
+{$ifdef FPC_MANAGED_MOVE}
+      if domove then
+        begin
+          fpc_WideStr_Decr_Ref(PPointer(Dest)^);
+          PPointer(Dest)^:=PPointer(src)^;
+          PPointer(Src)^:=nil;
+        end
+      else
+{$endif FPC_MANAGED_MOVE}
       fpc_WideStr_Assign(PPointer(Dest)^,PPointer(Src)^);
   {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
     tkUstring:
+{$ifdef FPC_MANAGED_MOVE}
+      if domove then
+        begin
+          fpc_UnicodeStr_Decr_Ref(PPointer(Dest)^);
+          PPointer(Dest)^:=PPointer(src)^;
+          PPointer(Src)^:=nil;
+        end
+      else
+{$endif FPC_MANAGED_MOVE}
       fpc_UnicodeStr_Assign(PPointer(Dest)^,PPointer(Src)^);
 {$endif FPC_HAS_FEATURE_WIDESTRINGS}
     tkArray:
@@ -291,7 +324,11 @@ begin
         { Process elements }
         for I:=1 to EleCount do
           begin
+{$ifdef FPC_MANAGED_MOVE}
+            fpc_Copy_internal(Src+Offset,Dest+Offset,Info,DoMove);
+{$else}
             fpc_Copy_internal(Src+Offset,Dest+Offset,Info);
+{$endif FPC_MANAGED_MOVE}
             inc(Offset,copiedsize);
           end;
       end;
@@ -302,6 +339,15 @@ begin
       begin
         Temp:=RTTIRecordInfoInit(typeinfo);
         Result:=PRecordInfoInit(Temp)^.Size;
+{$ifdef FPC_MANAGED_MOVE}
+        if domove then
+          begin
+            int_finalize(Dest,TypeInfo);
+            move(src^,dest^,result);
+            int_initialize(Src,TypeInfo);
+          end
+        else
+{$endif FPC_MANAGED_MOVE}
         if Assigned(PRecordInfoInit(Temp)^.recordop) and Assigned(PRecordInfoInit(Temp)^.recordop^.Copy) then
           PRecordInfoInit(Temp)^.recordop^.Copy(Src,Dest)
         else
@@ -316,7 +362,11 @@ begin
                 Offset:=PRecordElement(Temp)^.Offset;
                 if Offset>expectedoffset then
                   move((Src+expectedoffset)^,(Dest+expectedoffset)^,Offset-expectedoffset);
+{$ifdef FPC_MANAGED_MOVE}
+                expectedoffset:=Offset+fpc_Copy_internal(Src+Offset,Dest+Offset,PRecordElement(Temp)^.TypeInfo^,DoMove);
+{$else}
                 expectedoffset:=Offset+fpc_Copy_internal(Src+Offset,Dest+Offset,PRecordElement(Temp)^.TypeInfo^);
+{$endif FPC_MANAGED_MOVE}
                 Inc(PRecordElement(Temp));
               end;
             { elements remaining? }
@@ -326,10 +376,27 @@ begin
       end;
 {$ifdef FPC_HAS_FEATURE_DYNARRAYS}
     tkDynArray:
+{$ifdef FPC_MANAGED_MOVE}
+      if domove then
+        begin
+          fpc_dynarray_clear(PPointer(Dest)^,TypeInfo);
+          PPointer(Dest)^:=PPointer(src)^;
+          PPointer(Src)^:=nil;
+        end
+      else
+{$endif FPC_MANAGED_MOVE}
       fpc_dynarray_assign(PPointer(Dest)^,PPointer(Src)^,typeinfo);
 {$endif FPC_HAS_FEATURE_DYNARRAYS}
 {$ifdef FPC_HAS_FEATURE_CLASSES}
     tkInterface:
+{$ifdef FPC_MANAGED_MOVE}
+      if domove then
+        begin
+          PPointer(Dest)^:=PPointer(src)^;
+          PPointer(Src)^:=nil;
+        end
+      else
+{$endif FPC_MANAGED_MOVE}
       fpc_intf_assign(PPointer(Dest)^,PPointer(Src)^);
 {$endif FPC_HAS_FEATURE_CLASSES}
 {$ifdef FPC_HAS_FEATURE_VARIANTS}
@@ -346,10 +413,17 @@ end;
 { For internal use by the compiler, because otherwise $x- can cause trouble. }
 { Generally disabling extended syntax checking for all compilerprocs may     }
 { have unintended side-effects                                               }
+{$ifdef FPC_MANAGED_MOVE}
+procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer; DoMove : Boolean);compilerproc; inline;
+begin
+  fpc_copy_internal(src,dest,typeinfo,domove);
+end;
+{$else}
 procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer);compilerproc; inline;
 begin
   fpc_copy_internal(src,dest,typeinfo);
 end;
+{$endif FPC_MANAGED_MOVE}
 
 
 procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); [public,alias:'FPC_INITIALIZE_ARRAY']; compilerproc;
@@ -404,6 +478,10 @@ procedure CopyArray(dest, source, typeInfo: Pointer; count: SizeInt);
   begin
     if RTTIManagementAndSize(typeinfo, rotCopy, size, manBuiltin)<>manNone then
       for i:=0 to count-1 do
+{$ifdef FPC_MANAGED_MOVE}
+        fpc_Copy_internal(source+size*i, dest+size*i, typeInfo, False);
+{$else}
         fpc_Copy_internal(source+size*i, dest+size*i, typeInfo);
+{$endif FPC_MANAGED_MOVE}
   end;
 

rtl/inc/systemh.inc

@@ -97,6 +97,11 @@
 {$define USE_FILEREC_FULLNAME}
 {$endif defined(FPC_HAS_FEATURE_UNICODESTRINGS)}
 
+{ allow for lightweight move of managed records }
+{$if FPC_FULLVERSION>=30301}
+{$define FPC_MANAGED_MOVE}
+{$endif }
+
 {****************************************************************************
                          Global Types and Constants
 ****************************************************************************}

rtl/java/jcompproc.inc

@@ -701,8 +701,8 @@ procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); compile
 procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); compilerproc;
 procedure fpc_addref_array(data,typeinfo: pointer; count: SizeInt); compilerproc;
 procedure fpc_decref_array(data,typeinfo: pointer; count: sizeint); compilerproc;
-Function fpc_Copy (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc;
-Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
+Function fpc_Copy (Src, Dest, TypeInfo : Pointer; DoMove : Boolean) : SizeInt; compilerproc;
+Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer; DoMove : Boolean); compilerproc; inline;
 {$endif FPC_HAS_FEATURE_RTTI}
 *)
 { array initialisation helpers (for open array "out" parameters whose elements

tests/test/tmoperator12.pp

@@ -0,0 +1,41 @@
+{$Mode ObjFpc}{$H+}
+{$ModeSwitch AdvancedRecords}
+
+type
+  TMyRec = record
+    i: Integer;
+    class operator :=(const rhs: Integer): TMyRec;
+    class operator Copy(constref src: TMyRec; var dst: TMyRec);
+    class operator +(const lhs,rhs: TMyRec): TMyRec;
+  end;
+
+class operator TMyRec.:=(const rhs: Integer): TMyRec;
+begin
+  Result.i:=rhs;
+end;
+
+var
+  CopyCount: Integer = 0;
+class operator TMyRec.Copy(constref src: TMyRec; var dst: TMyRec);
+begin
+  Inc(CopyCount);
+  dst.i:=src.i;
+end;
+
+class operator TMyRec.+(const lhs,rhs: TMyRec): TMyRec;
+begin
+  Result.i:=lhs.i+rhs.i;
+end;
+
+var
+  r1, r2, r3: TMyRec;
+begin
+  r1 := 42;
+  r2 := 32;
+  r3 := r1 + r2;
+  if r3.i<>42+32 then
+    Halt(1);
+  if CopyCount <> 0 then
+    Halt(2);
+  WriteLn('Ok');
+end.