View Issue Details

IDProjectCategoryView StatusLast Update
0035825FPCCompilerpublic2019-07-11 16:22
ReporterRyan JosephAssigned To 
PrioritynormalSeverityminorReproducibilityN/A
Status newResolutionopen 
Product Version3.3.1Product Build 
Target VersionFixed in Version 
Summary0035825: [PATCH] Move management operator
DescriptionIntroduces a new "Move" management operator which works as a companion to "Copy" to improve efficiency.

Currently during all assignments the Copy operator is called, even if the record being copied is "temporary" and thus doesn't have a static memory address. With the proposed patch the Move operator will now be called in these situations which gives the programmer the option to simply move memory instead of performing an actual copy. If the Move operator is not present the Copy operator will be called always.
Additional Information{$mode objfpc}
{$modeswitch advancedrecords}

program test;

type
  TMyRecord = record
    data: TData;
    constructor Create(val: integer);
    class operator Copy(constref aSrc: TMyRecord; var aDst: TMyRecord);
    class operator Move(constref aSrc: TMyRecord; var aDst: TMyRecord);
  end;

constructor TMyRecord.Create(val: integer);
begin
  data := TData.Create;
end;

class operator TMyRecord.Copy(constref aSrc: TMyRecord; var aDst: TMyRecord);
begin
  { ...do something... }
  aDst.data := TData.Create;
end;

class operator TMyRecord.Move(constref aSrc: TMyRecord; var aDst: TMyRecord);
begin
  aSrc.data := ADst.data;
end;

operator := (right: integer): TMyRecord;
begin
  { Move operator called because right side is temporary }
  result := TMyRecord.Create(right);
end;

var
  a, b: TMyRecord;
begin
  { Move operator is called because the right side from the
    := operator is temporary. In total the move operator is
    called twice in this line saving two copies }
  a := 1;
  { Copy operator is called because "a" is static memory }
  b := a;
end.
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files
  • moveop_7_9.diff (21,686 bytes)
    From fc07e6d9ed4ace42d4a100a4a4b439794e09b128 Mon Sep 17 00:00:00 2001
    From: Ryan Joseph <genericptr@gmail.com>
    Date: Sat, 15 Jun 2019 10:48:30 -0400
    Subject: [PATCH] Move management operator
    
    ---
     .gitignore             |  24 +++++++
     compiler/htypechk.pas  |   5 +-
     compiler/ncal.pas      |   5 ++
     compiler/nld.pas       |   8 ++-
     compiler/nmem.pas      |  24 ++++++-
     compiler/node.pas      |  24 ++++++-
     compiler/pdecsub.pas   |   5 +-
     compiler/symconst.pas  |   3 +-
     compiler/symtable.pas  |   4 +-
     compiler/tokens.pas    |   6 +-
     rtl/inc/compproc.inc   |   2 +
     rtl/inc/rtti.inc       |  72 ++++++++++++++++++++
     rtl/inc/rttidecl.inc   |   4 +-
     tests/test/tmoveop1.pp | 150 +++++++++++++++++++++++++++++++++++++++++
     tests/test/tmoveop2.pp |  31 +++++++++
     15 files changed, 356 insertions(+), 11 deletions(-)
     create mode 100644 .gitignore
     create mode 100644 tests/test/tmoveop1.pp
     create mode 100644 tests/test/tmoveop2.pp
    
    diff --git a/.gitignore b/.gitignore
    new file mode 100644
    index 0000000000..8b577f31db
    --- /dev/null
    +++ b/.gitignore
    @@ -0,0 +1,24 @@
    +# files
    +pp
    +fpmake
    +rtl/darwin/fpcmade.x86_64-darwin
    +fpmake_proc1 copy.inc
    +tests/*.x86_64-darwin
    +rtl/Package.fpc
    +tests/createlst
    +tests/gparmake
    +#compiler/ryan_ppcx64.lpi
    +
    +# directories
    +lazbuild/
    +x86_64-darwin/
    +tests/tstunits/
    +tests/utils
    +
    +# patterns
    +*.app
    +*.o
    +*.ppu
    +*.fpm
    +*.rsj
    +*.lst
    \ No newline at end of file
    diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
    index 2a9f378f75..f84bbe9004 100644
    --- a/compiler/htypechk.pas
    +++ b/compiler/htypechk.pas
    @@ -142,12 +142,13 @@ interface
             (tok:_OP_DEC     ;nod:inlinen;inr:in_dec_x;op_overloading_supported:true;minargs:1;maxargs:1)   { unary overloading supported }
           );
     
    -      tok2ops=4;
    +      tok2ops=5;
           tok2op: array[1..tok2ops] of ttok2oprec=(
             (tok:_OP_INITIALIZE; managementoperator: mop_initialize),
             (tok:_OP_FINALIZE  ; managementoperator: mop_finalize),
             (tok:_OP_ADDREF    ; managementoperator: mop_addref),
    -        (tok:_OP_COPY      ; managementoperator: mop_copy)
    +        (tok:_OP_COPY      ; managementoperator: mop_copy),
    +        (tok:_OP_MOVE      ; managementoperator: mop_move)
           );
     
         function node2opstr(nt:tnodetype):string;
    diff --git a/compiler/ncal.pas b/compiler/ncal.pas
    index 546a1a0d99..e15471d44f 100644
    --- a/compiler/ncal.pas
    +++ b/compiler/ncal.pas
    @@ -90,6 +90,7 @@ interface
               function  pass1_normal:tnode;
               procedure register_created_object_types;
               function get_expect_loc: tcgloc;
    +          function memory_mapping : tnode_memory_mapping;override;
            protected
               function safe_call_self_node: tnode;
               procedure gen_vmt_entry_load; virtual;
    @@ -2562,6 +2563,10 @@ implementation
               result:=LOC_REFERENCE
           end;
     
    +    function tcallnode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        result:=nmm_temporary;
    +      end;
     
         function tcallnode.safe_call_self_node: tnode;
           begin
    diff --git a/compiler/nld.pas b/compiler/nld.pas
    index 65a82a13f1..b2a2b04bc0 100644
    --- a/compiler/nld.pas
    +++ b/compiler/nld.pas
    @@ -779,6 +779,7 @@ implementation
             hdef: tdef;
             hs: string;
             needrtti: boolean;
    +        st: tsymtable;
           begin
              result:=nil;
              expectloc:=LOC_VOID;
    @@ -846,7 +847,12 @@ implementation
                    ccallparanode.create(ctypeconvnode.create_internal(
                      caddrnode.create_internal(right),voidpointertype),
                    nil)));
    -           result:=ccallnode.createintern('fpc_copy_proc',hp);
    +           { if the move operator is implemented it takes precedence over copy }
    +           st:=tabstractrecorddef(left.resultdef).symtable;
    +           if (mop_move in trecordsymtable(st).managementoperators) and (right.memory_mapping=nmm_temporary) then
    +             result:=ccallnode.createintern('fpc_move_proc',hp)
    +           else
    +             result:=ccallnode.createintern('fpc_copy_proc',hp);
                firstpass(result);
                left:=nil;
                right:=nil;
    diff --git a/compiler/nmem.pas b/compiler/nmem.pas
    index ec36ceead6..28dcf026c2 100644
    --- a/compiler/nmem.pas
    +++ b/compiler/nmem.pas
    @@ -105,6 +105,7 @@ interface
               function pass_1 : tnode;override;
               function pass_typecheck:tnode;override;
               procedure mark_write;override;
    +          function memory_mapping : tnode_memory_mapping;override;
            end;
            tderefnodeclass = class of tderefnode;
     
    @@ -133,6 +134,7 @@ interface
               function pass_1 : tnode;override;
               function pass_typecheck:tnode;override;
               procedure mark_write;override;
    +          function memory_mapping : tnode_memory_mapping;override;
            end;
            tvecnodeclass = class of tvecnode;
     
    @@ -766,6 +768,11 @@ implementation
           include(flags,nf_write);
         end;
     
    +    function Tderefnode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        result:=nmm_static;
    +      end;
    +
         function tderefnode.pass_1 : tnode;
           begin
              result:=nil;
    @@ -851,7 +858,6 @@ implementation
               left.mark_write;
           end;
     
    -
         function tsubscriptnode.pass_1 : tnode;
           begin
              result:=nil;
    @@ -1163,6 +1169,22 @@ implementation
           end;
     
     
    +    function tvecnode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        // TODO: if right is a constant and left is constant array we should in therory
    +        // be able to determine at compile time if the value is mapped or not
    +        if is_array_constructor(left.resultdef) or
    +           is_dynamic_array(left.resultdef) or
    +           is_open_array(left.resultdef) and
    +           is_ordinal(right.resultdef) then
    +          begin
    +            result:=inherited memory_mapping;
    +          end
    +        else
    +          result:=left.memory_mapping;
    +      end;
    +
    +
         function tvecnode.pass_1 : tnode;
           begin
              result:=nil;
    diff --git a/compiler/node.pas b/compiler/node.pas
    index a0aad228eb..609354a1af 100644
    --- a/compiler/node.pas
    +++ b/compiler/node.pas
    @@ -295,6 +295,14 @@ interface
            tnodelist = class
            end;
     
    +      tnode_memory_mapping = (  { no memory mapping was explicitly given for the node (the default) }
    +                                nmm_unspecified,  
    +                                { the node maps to static (e.g. addressable) memory }
    +                                nmm_static,       
    +                                { the node maps to temporary memory (e.g. the address can not be gotten using @) }
    +                                nmm_temporary     
    +                             );
    +
           pnode = ^tnode;
           { basic class for the intermediated representation fpc uses }
           tnode = class
    @@ -385,6 +393,7 @@ interface
              procedure printnodetree(var t:text);virtual;
              procedure concattolist(l : tlinkedlist);virtual;
              function ischild(p : tnode) : boolean;virtual;
    +         function memory_mapping : tnode_memory_mapping;virtual;
     
              { ensures that the optimizer info record is allocated }
              function allocoptinfo : poptinfo;inline;
    @@ -409,6 +418,7 @@ interface
              procedure derefimpl;override;
              procedure concattolist(l : tlinkedlist);override;
              function ischild(p : tnode) : boolean;override;
    +         function memory_mapping : tnode_memory_mapping;override;
              function docompare(p : tnode) : boolean;override;
              function dogetcopy : tnode;override;
              procedure insertintolist(l : tnodelist);override;
    @@ -846,6 +856,12 @@ implementation
           end;
     
     
    +    function tnode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        result:=nmm_unspecified;
    +      end;
    +
    +
         procedure tnode.mark_write;
           begin
     {$ifdef EXTDEBUG}
    @@ -1072,6 +1088,13 @@ implementation
              ischild:=p=left;
           end;
     
    +    function tunarynode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        if assigned(left) then
    +          result:=left.memory_mapping
    +        else
    +          result:=inherited memory_mapping;
    +      end;
     
     {****************************************************************************
                                 TBINARYNODE
    @@ -1138,7 +1161,6 @@ implementation
              ischild:=(p=right);
           end;
     
    -
         function tbinarynode.docompare(p : tnode) : boolean;
           begin
              docompare:=(inherited docompare(p) and
    diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
    index d600583fef..295ad90154 100644
    --- a/compiler/pdecsub.pas
    +++ b/compiler/pdecsub.pas
    @@ -572,6 +572,7 @@ implementation
                         _FINALIZE:optoken:=_OP_FINALIZE;
                         _ADDREF:optoken:=_OP_ADDREF;
                         _COPY:optoken:=_OP_COPY;
    +                    _MOVE:optoken:=_OP_MOVE;
                         else
                         if (m_delphi in current_settings.modeswitches) then
                           case lastidtoken of
    @@ -1452,7 +1453,7 @@ implementation
                       consume(_ID);
                     end;
                   { operators without result (management operators) }
    -              if optoken in [_OP_INITIALIZE, _OP_FINALIZE, _OP_ADDREF, _OP_COPY] then
    +              if optoken in [_OP_INITIALIZE,_OP_FINALIZE,_OP_ADDREF,_OP_COPY,_OP_MOVE] then
                     begin
                       { single var parameter to point the record }
                       if (optoken in [_OP_INITIALIZE, _OP_FINALIZE, _OP_ADDREF]) and
    @@ -1463,7 +1464,7 @@ implementation
                          ) then
                         Message(parser_e_overload_impossible)
                       { constref (source) and var (dest) parameter to point the records }
    -                  else if (optoken=_OP_COPY) and
    +                  else if (optoken in [_OP_COPY,_OP_MOVE]) and
                          (
                           (pd.parast.SymList.Count<>2) or
                           (tparavarsym(pd.parast.SymList[0]).vardef<>pd.struct) or
    diff --git a/compiler/symconst.pas b/compiler/symconst.pas
    index 5904dbeac7..1f76000f0d 100644
    --- a/compiler/symconst.pas
    +++ b/compiler/symconst.pas
    @@ -610,7 +610,8 @@ type
         mop_initialize,
         mop_finalize,
         mop_addref,
    -    mop_copy
    +    mop_copy,
    +    mop_move
       );
       tmanagementoperators=set of tmanagementoperator;
     
    diff --git a/compiler/symtable.pas b/compiler/symtable.pas
    index 305d39904a..4d4d6d82ad 100644
    --- a/compiler/symtable.pas
    +++ b/compiler/symtable.pas
    @@ -458,6 +458,7 @@ interface
         { _OP_FINALIZE   }  'finalize',
         { _OP_ADDREF     }  'addref',
         { _OP_COPY       }  'copy',
    +    { _OP_MOVE       }  'move',
         { _OP_INC        }  'inc',
         { _OP_DEC        }  'dec');
     
    @@ -466,7 +467,8 @@ interface
         { mop_initialize }  _OP_INITIALIZE,
         { mop_finalize   }  _OP_FINALIZE,
         { mop_addref     }  _OP_ADDREF,
    -    { mop_copy       }  _OP_COPY
    +    { mop_copy       }  _OP_COPY,
    +    { mop_move       }  _OP_MOVE
         );
     
     
    diff --git a/compiler/tokens.pas b/compiler/tokens.pas
    index e208e6bbd8..2cceab0171 100644
    --- a/compiler/tokens.pas
    +++ b/compiler/tokens.pas
    @@ -60,6 +60,7 @@ type
         _OP_FINALIZE,
         _OP_ADDREF,
         _OP_COPY,
    +    _OP_MOVE,
         _OP_INC,
         _OP_DEC,
         { special chars }
    @@ -141,6 +142,7 @@ type
         _FILE,
         _GOTO,
         _HUGE,
    +    _MOVE,
         _NAME,
         _NEAR,
         _READ,
    @@ -337,7 +339,7 @@ const
       last_overloaded  = _OP_DEC;
       last_operator = _GENERICSPECIALTOKEN;
       first_managment_operator = _OP_INITIALIZE;
    -  last_managment_operator = _OP_COPY;
    +  last_managment_operator = _OP_MOVE;
     
       highest_precedence = oppower;
     
    @@ -401,6 +403,7 @@ const
           (str:'finalize'      ;special:true ;keyword:[m_none];op:NOTOKEN),
           (str:'addref'        ;special:true ;keyword:[m_none];op:NOTOKEN),
           (str:'copy'          ;special:true ;keyword:[m_none];op:NOTOKEN),
    +      (str:'move'          ;special:true ;keyword:[m_none];op:NOTOKEN),
           (str:'inc'           ;special:true ;keyword:[m_none];op:NOTOKEN),
           (str:'dec'           ;special:true ;keyword:[m_none];op:NOTOKEN),
         { Special chars }
    @@ -482,6 +485,7 @@ const
           (str:'FILE'          ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
           (str:'GOTO'          ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
           (str:'HUGE'          ;special:false;keyword:[m_none];op:NOTOKEN),
    +      (str:'MOVE'          ;special:false;keyword:[m_none];op:NOTOKEN),
           (str:'NAME'          ;special:false;keyword:[m_none];op:NOTOKEN),
           (str:'NEAR'          ;special:false;keyword:[m_none];op:NOTOKEN),
           (str:'READ'          ;special:false;keyword:[m_none];op:NOTOKEN),
    diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc
    index 4bb4e8937b..6ec67746aa 100644
    --- a/rtl/inc/compproc.inc
    +++ b/rtl/inc/compproc.inc
    @@ -743,7 +743,9 @@ procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); compilerp
     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;
    +Function fpc_Move (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc;
     Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
    +Procedure fpc_Move_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
     {$endif FPC_HAS_FEATURE_RTTI}
     
     
    diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc
    index 46cae4c2dd..cda4fe4c07 100644
    --- a/rtl/inc/rtti.inc
    +++ b/rtl/inc/rtti.inc
    @@ -104,6 +104,7 @@ begin
                   rotFinalize: hasManagementOp:=Assigned(RecordOp^.Finalize);
                   rotAddRef: hasManagementOp:=Assigned(RecordOp^.AddRef);
                   rotCopy: hasManagementOp:=Assigned(RecordOp^.Copy);
    +              rotMove: hasManagementOp:=Assigned(RecordOp^.Move);
                 end;
             end;
     {$else VER3_0}
    @@ -451,6 +452,77 @@ begin
       fpc_copy_internal(src,dest,typeinfo);
     end;
     
    +{ define alias for internal use in the system unit }
    +Function fpc_Move_internal (Src, Dest, TypeInfo : Pointer) : SizeInt;[external name 'FPC_MOVE'];
    +
    +Function fpc_Move (Src, Dest, TypeInfo : Pointer) : SizeInt;[Public,alias : 'FPC_MOVE']; compilerproc;
    +var
    +  Temp: pbyte;
    +  copiedsize,
    +  expectedoffset,
    +  count,
    +  offset,
    +  i: SizeInt;
    +  info: pointer;
    +begin
    +  result:=sizeof(pointer);
    +  case PTypeKind(TypeInfo)^ of
    +{$ifdef FPC_HAS_FEATURE_OBJECTS}
    +    tkobject,
    +{$endif FPC_HAS_FEATURE_OBJECTS}
    +    tkrecord:
    +{$ifndef VER3_0}
    +      { find init table }
    +      with RTTIRecordOp(typeinfo, typeinfo)^ do
    +{$endif VER3_0}
    +      begin
    +{$ifdef VER3_0}
    +        typeInfo:=RTTIRecordRttiInfoToInitInfo(typeInfo);
    +        Temp:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
    +{$else VER3_0}
    +        Temp:=aligntoqword(typeInfo+2+PByte(typeInfo)[1]);
    +{$endif VER3_0}
    +{$ifndef VER3_0}
    +        if Assigned(recordop) and Assigned(recordop^.Move) then
    +          recordop^.Move(Src,Dest)
    +        else
    +          begin
    +            Result:=Size;
    +            Inc(PRecordInfoInit(Temp));
    +{$else VER3_0}
    +            Result:=PRecordInfoFull(Temp)^.Size;
    +            Count:=PRecordInfoFull(Temp)^.Count;
    +            Inc(PRecordInfoFull(Temp));
    +{$endif VER3_0}
    +            expectedoffset:=0;
    +            { Process elements with rtti }
    +            for i:=1 to Count Do
    +              begin
    +                Info:=PRecordElement(Temp)^.TypeInfo{$ifndef VER3_0}^{$endif};
    +                Offset:=PRecordElement(Temp)^.Offset;
    +                Inc(PRecordElement(Temp));
    +                if Offset>expectedoffset then
    +                  move((Src+expectedoffset)^,(Dest+expectedoffset)^,Offset-expectedoffset);
    +                copiedsize:=fpc_Move_internal(Src+Offset,Dest+Offset,Info);
    +                expectedoffset:=Offset+copiedsize;
    +              end;
    +            { elements remaining? }
    +            if result>expectedoffset then
    +              move((Src+expectedoffset)^,(Dest+expectedoffset)^,Result-expectedoffset);
    +{$ifndef VER3_0}
    +          end;
    +{$endif VER3_0}
    +      end;
    +  end;
    +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                                               }
    +procedure fpc_Move_proc (Src, Dest, TypeInfo : Pointer);compilerproc; inline;
    +begin
    +  fpc_move_internal(src,dest,typeinfo);
    +end;
     
     procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); [public,alias:'FPC_INITIALIZE_ARRAY']; compilerproc;
       var
    diff --git a/rtl/inc/rttidecl.inc b/rtl/inc/rttidecl.inc
    index 55a4e6cfe6..a5135a9663 100644
    --- a/rtl/inc/rttidecl.inc
    +++ b/rtl/inc/rttidecl.inc
    @@ -79,7 +79,8 @@ type
     {$ifndef VER3_0}
       TRTTIRecVarOp=procedure(ARec: Pointer);
       TRTTIRecCopyOp=procedure(ASrc, ADest: Pointer);
    -  TRTTIRecOpType=(rotAny, rotInitialize, rotFinalize, rotAddRef, rotCopy);
    +  TRTTIRecMoveOp=procedure(ASrc, ADest: Pointer);
    +  TRTTIRecOpType=(rotAny, rotInitialize, rotFinalize, rotAddRef, rotCopy, rotMove);
       PRTTIRecordOpVMT=^TRTTIRecordOpVMT;
       TRTTIRecordOpVMT=
     {$ifdef USE_PACKED}
    @@ -90,6 +91,7 @@ type
         Finalize: TRTTIRecVarOp;
         AddRef: TRTTIRecVarOp;
         Copy: TRTTIRecCopyOp;
    +    Move: TRTTIRecMoveOp;
       end;
     
       TRTTIRecordOpOffsetEntry =
    diff --git a/tests/test/tmoveop1.pp b/tests/test/tmoveop1.pp
    new file mode 100644
    index 0000000000..3c1560676a
    --- /dev/null
    +++ b/tests/test/tmoveop1.pp
    @@ -0,0 +1,150 @@
    +{$mode objfpc}
    +{$modeswitch advancedrecords}
    +
    +program tmoveop1;
    +
    +type
    +  TCopyOperations = (op_copy, op_move, op_uknown);
    +var
    +  LastOperation: TCopyOperations;
    +
    +type
    +  TBase = record
    +    constructor Create(val: integer);
    +    class operator Copy(constref aSrc: TBase; var aDst: TBase);
    +    class operator Move(constref aSrc: TBase; var aDst: TBase);
    +  end;
    +  PBase = ^TBase;
    +  TBaseAlias = TBase;
    +
    +constructor TBase.Create(val: integer);
    +begin
    +end;
    +
    +class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
    +begin
    +  LastOperation := op_copy;
    +end;
    +
    +class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
    +begin
    +  LastOperation := op_move;
    +end;
    +
    +type
    +  TMyClass = class
    +    a: TBase;
    +    function GetBase: TBase;
    +    function GetBase_inline: TBase; inline;
    +    property a0: TBase read a;
    +    property a1: TBase read GetBase;
    +    property a2: TBase read GetBase_inline;
    +  end;
    +
    +function TMyClass.GetBase: TBase;
    +begin
    +  result := a;
    +end;
    +
    +function TMyClass.GetBase_inline: TBase;
    +begin
    +  result := a;
    +end;
    +
    +var
    +  gBase: TBase;
    +
    +function get_pbase: PBase;
    +begin
    +  result := @gBase;
    +end;
    +
    +function get_base: TBase;
    +begin
    +  result := gBase;
    +end;
    +
    +procedure FailIfNot(op: TCopyOperations);
    +begin
    +  if LastOperation <> op then
    +    begin
    +      writeln('FAILED! LastOperation=', LastOperation, ' should be ', op);
    +      halt(-1);
    +    end;
    +end;
    +
    +var
    +  a,b: TBase;
    +  p: PBase;
    +  r: array of TBase;
    +  c: TMyClass;
    +begin
    +
    +  { load nodes are always copies becase they point to static memory }
    +  LastOperation := op_uknown;
    +  a := b;
    +  FailIfNot(op_copy);
    +
    +  LastOperation := op_uknown;
    +  a := TBaseAlias(b);
    +  FailIfNot(op_copy);
    +
    +  { deref nodes always default to copy because we can't confirm at
    +    compile time that they point to temporary memory or not }
    +  LastOperation := op_uknown;
    +  a := get_pbase^;
    +  FailIfNot(op_copy);
    +
    +  LastOperation := op_uknown;
    +  a := pbase(@get_base)^;
    +  FailIfNot(op_copy);
    +
    +  { call nodes are a move operation because the function is always 
    +    copy-on-pass in pascal }
    +  LastOperation := op_uknown;
    +  a := get_base;
    +  FailIfNot(op_move);
    +
    +  { constructors are call nodes so same rules apply }
    +  LastOperation := op_uknown;
    +  a := TBase.Create(1);
    +  FailIfNot(op_move);
    +
    +  { dynamic arrays - same rules apply as normal assignments }
    +  LastOperation := op_uknown;
    +  r := [a];
    +  FailIfNot(op_copy);
    +
    +  { dynamic arrays - same rules apply as normal assignments }
    +  LastOperation := op_uknown;
    +  r := [TBase.Create(1)];
    +  FailIfNot(op_move);
    +
    +  { vector nodes always default to copy because we can't confirm at
    +    compile time that they point to temporary memory or not }
    +  LastOperation := op_uknown;
    +  a := r[0];
    +  FailIfNot(op_copy);
    +
    +  { subscript node to field is static memory }
    +  c := TMyClass.Create;
    +  LastOperation := op_uknown;
    +  a := c.a;
    +  FailIfNot(op_copy);
    +
    +  { read property is fieldvarsym which is static memory }
    +  LastOperation := op_uknown;
    +  a := c.a0;
    +  FailIfNot(op_copy);
    +
    +  { read property with getter function is call node and temporary }
    +  LastOperation := op_uknown;
    +  a := c.a1;
    +  FailIfNot(op_move);
    +
    +  { read property with getter function is inlined so it maps
    +    directly to a field and should be a copy }
    +  LastOperation := op_uknown;
    +  a := c.a2;
    +  FailIfNot(op_copy);
    +end.
    diff --git a/tests/test/tmoveop2.pp b/tests/test/tmoveop2.pp
    new file mode 100644
    index 0000000000..9c57e06106
    --- /dev/null
    +++ b/tests/test/tmoveop2.pp
    @@ -0,0 +1,31 @@
    +{$mode objfpc}
    +{$modeswitch advancedrecords}
    +
    +program tmoveop2;
    +
    +type
    +  TBase = record
    +    constructor Create(val: integer);
    +    class operator Copy(constref aSrc: TBase; var aDst: TBase);
    +  end;
    +
    +var
    +  CopyCalled: boolean = false;
    +
    +constructor TBase.Create(val: integer);
    +begin
    +end;
    +
    +class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
    +begin
    +  CopyCalled := true;
    +end;
    +
    +var
    +  a: TBase;
    +begin
    +  // the move operator is not implemented so copy operator is used
    +  a := TBase.Create(1);
    +  if not CopyCalled then
    +    Halt(-1);
    +end.
    -- 
    2.17.2 (Apple Git-113)
    
    
    moveop_7_9.diff (21,686 bytes)
  • patch_7_11.diff (25,437 bytes)
    From 2089842e5b393ff8e626d980804b8689b3251e75 Mon Sep 17 00:00:00 2001
    From: Ryan Joseph <genericptr@gmail.com>
    Date: Sat, 15 Jun 2019 10:48:30 -0400
    Subject: [PATCH] Move operator
    
    ---
     compiler/htypechk.pas  |   5 +-
     compiler/ncal.pas      |   5 ++
     compiler/nld.pas       |   6 +-
     compiler/nmem.pas      |  24 ++++++-
     compiler/node.pas      |  24 ++++++-
     compiler/pdecsub.pas   |   5 +-
     compiler/symconst.pas  |   3 +-
     compiler/symtable.pas  |   4 +-
     compiler/tokens.pas    |   6 +-
     rtl/inc/compproc.inc   |   2 +
     rtl/inc/rtti.inc       | 131 +++++++++++++++++++++++++++++++++++
     rtl/inc/rttidecl.inc   |   4 +-
     tests/test/tmoveop1.pp | 150 +++++++++++++++++++++++++++++++++++++++++
     tests/test/tmoveop2.pp |  31 +++++++++
     tests/test/tmoveop3.pp |  42 ++++++++++++
     tests/test/tmoveop4.pp |  53 +++++++++++++++
     16 files changed, 484 insertions(+), 11 deletions(-)
     create mode 100644 tests/test/tmoveop1.pp
     create mode 100644 tests/test/tmoveop2.pp
     create mode 100644 tests/test/tmoveop3.pp
     create mode 100644 tests/test/tmoveop4.pp
    
    diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
    index 2a9f378f75..f84bbe9004 100644
    --- a/compiler/htypechk.pas
    +++ b/compiler/htypechk.pas
    @@ -142,12 +142,13 @@ interface
             (tok:_OP_DEC     ;nod:inlinen;inr:in_dec_x;op_overloading_supported:true;minargs:1;maxargs:1)   { unary overloading supported }
           );
     
    -      tok2ops=4;
    +      tok2ops=5;
           tok2op: array[1..tok2ops] of ttok2oprec=(
             (tok:_OP_INITIALIZE; managementoperator: mop_initialize),
             (tok:_OP_FINALIZE  ; managementoperator: mop_finalize),
             (tok:_OP_ADDREF    ; managementoperator: mop_addref),
    -        (tok:_OP_COPY      ; managementoperator: mop_copy)
    +        (tok:_OP_COPY      ; managementoperator: mop_copy),
    +        (tok:_OP_MOVE      ; managementoperator: mop_move)
           );
     
         function node2opstr(nt:tnodetype):string;
    diff --git a/compiler/ncal.pas b/compiler/ncal.pas
    index 546a1a0d99..e15471d44f 100644
    --- a/compiler/ncal.pas
    +++ b/compiler/ncal.pas
    @@ -90,6 +90,7 @@ interface
               function  pass1_normal:tnode;
               procedure register_created_object_types;
               function get_expect_loc: tcgloc;
    +          function memory_mapping : tnode_memory_mapping;override;
            protected
               function safe_call_self_node: tnode;
               procedure gen_vmt_entry_load; virtual;
    @@ -2562,6 +2563,10 @@ implementation
               result:=LOC_REFERENCE
           end;
     
    +    function tcallnode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        result:=nmm_temporary;
    +      end;
     
         function tcallnode.safe_call_self_node: tnode;
           begin
    diff --git a/compiler/nld.pas b/compiler/nld.pas
    index 65a82a13f1..0d870b4997 100644
    --- a/compiler/nld.pas
    +++ b/compiler/nld.pas
    @@ -846,7 +846,11 @@ implementation
                    ccallparanode.create(ctypeconvnode.create_internal(
                      caddrnode.create_internal(right),voidpointertype),
                    nil)));
    -           result:=ccallnode.createintern('fpc_copy_proc',hp);
    +           { if the right node is temporary memory mapped then call move }
    +           if right.memory_mapping=nmm_temporary then
    +             result:=ccallnode.createintern('fpc_move_proc',hp)
    +           else
    +             result:=ccallnode.createintern('fpc_copy_proc',hp);
                firstpass(result);
                left:=nil;
                right:=nil;
    diff --git a/compiler/nmem.pas b/compiler/nmem.pas
    index ec36ceead6..28dcf026c2 100644
    --- a/compiler/nmem.pas
    +++ b/compiler/nmem.pas
    @@ -105,6 +105,7 @@ interface
               function pass_1 : tnode;override;
               function pass_typecheck:tnode;override;
               procedure mark_write;override;
    +          function memory_mapping : tnode_memory_mapping;override;
            end;
            tderefnodeclass = class of tderefnode;
     
    @@ -133,6 +134,7 @@ interface
               function pass_1 : tnode;override;
               function pass_typecheck:tnode;override;
               procedure mark_write;override;
    +          function memory_mapping : tnode_memory_mapping;override;
            end;
            tvecnodeclass = class of tvecnode;
     
    @@ -766,6 +768,11 @@ implementation
           include(flags,nf_write);
         end;
     
    +    function Tderefnode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        result:=nmm_static;
    +      end;
    +
         function tderefnode.pass_1 : tnode;
           begin
              result:=nil;
    @@ -851,7 +858,6 @@ implementation
               left.mark_write;
           end;
     
    -
         function tsubscriptnode.pass_1 : tnode;
           begin
              result:=nil;
    @@ -1163,6 +1169,22 @@ implementation
           end;
     
     
    +    function tvecnode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        // TODO: if right is a constant and left is constant array we should in therory
    +        // be able to determine at compile time if the value is mapped or not
    +        if is_array_constructor(left.resultdef) or
    +           is_dynamic_array(left.resultdef) or
    +           is_open_array(left.resultdef) and
    +           is_ordinal(right.resultdef) then
    +          begin
    +            result:=inherited memory_mapping;
    +          end
    +        else
    +          result:=left.memory_mapping;
    +      end;
    +
    +
         function tvecnode.pass_1 : tnode;
           begin
              result:=nil;
    diff --git a/compiler/node.pas b/compiler/node.pas
    index a0aad228eb..609354a1af 100644
    --- a/compiler/node.pas
    +++ b/compiler/node.pas
    @@ -295,6 +295,14 @@ interface
            tnodelist = class
            end;
     
    +      tnode_memory_mapping = (  { no memory mapping was explicitly given for the node (the default) }
    +                                nmm_unspecified,  
    +                                { the node maps to static (e.g. addressable) memory }
    +                                nmm_static,       
    +                                { the node maps to temporary memory (e.g. the address can not be gotten using @) }
    +                                nmm_temporary     
    +                             );
    +
           pnode = ^tnode;
           { basic class for the intermediated representation fpc uses }
           tnode = class
    @@ -385,6 +393,7 @@ interface
              procedure printnodetree(var t:text);virtual;
              procedure concattolist(l : tlinkedlist);virtual;
              function ischild(p : tnode) : boolean;virtual;
    +         function memory_mapping : tnode_memory_mapping;virtual;
     
              { ensures that the optimizer info record is allocated }
              function allocoptinfo : poptinfo;inline;
    @@ -409,6 +418,7 @@ interface
              procedure derefimpl;override;
              procedure concattolist(l : tlinkedlist);override;
              function ischild(p : tnode) : boolean;override;
    +         function memory_mapping : tnode_memory_mapping;override;
              function docompare(p : tnode) : boolean;override;
              function dogetcopy : tnode;override;
              procedure insertintolist(l : tnodelist);override;
    @@ -846,6 +856,12 @@ implementation
           end;
     
     
    +    function tnode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        result:=nmm_unspecified;
    +      end;
    +
    +
         procedure tnode.mark_write;
           begin
     {$ifdef EXTDEBUG}
    @@ -1072,6 +1088,13 @@ implementation
              ischild:=p=left;
           end;
     
    +    function tunarynode.memory_mapping : tnode_memory_mapping;
    +      begin
    +        if assigned(left) then
    +          result:=left.memory_mapping
    +        else
    +          result:=inherited memory_mapping;
    +      end;
     
     {****************************************************************************
                                 TBINARYNODE
    @@ -1138,7 +1161,6 @@ implementation
              ischild:=(p=right);
           end;
     
    -
         function tbinarynode.docompare(p : tnode) : boolean;
           begin
              docompare:=(inherited docompare(p) and
    diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
    index d600583fef..295ad90154 100644
    --- a/compiler/pdecsub.pas
    +++ b/compiler/pdecsub.pas
    @@ -572,6 +572,7 @@ implementation
                         _FINALIZE:optoken:=_OP_FINALIZE;
                         _ADDREF:optoken:=_OP_ADDREF;
                         _COPY:optoken:=_OP_COPY;
    +                    _MOVE:optoken:=_OP_MOVE;
                         else
                         if (m_delphi in current_settings.modeswitches) then
                           case lastidtoken of
    @@ -1452,7 +1453,7 @@ implementation
                       consume(_ID);
                     end;
                   { operators without result (management operators) }
    -              if optoken in [_OP_INITIALIZE, _OP_FINALIZE, _OP_ADDREF, _OP_COPY] then
    +              if optoken in [_OP_INITIALIZE,_OP_FINALIZE,_OP_ADDREF,_OP_COPY,_OP_MOVE] then
                     begin
                       { single var parameter to point the record }
                       if (optoken in [_OP_INITIALIZE, _OP_FINALIZE, _OP_ADDREF]) and
    @@ -1463,7 +1464,7 @@ implementation
                          ) then
                         Message(parser_e_overload_impossible)
                       { constref (source) and var (dest) parameter to point the records }
    -                  else if (optoken=_OP_COPY) and
    +                  else if (optoken in [_OP_COPY,_OP_MOVE]) and
                          (
                           (pd.parast.SymList.Count<>2) or
                           (tparavarsym(pd.parast.SymList[0]).vardef<>pd.struct) or
    diff --git a/compiler/symconst.pas b/compiler/symconst.pas
    index 5904dbeac7..1f76000f0d 100644
    --- a/compiler/symconst.pas
    +++ b/compiler/symconst.pas
    @@ -610,7 +610,8 @@ type
         mop_initialize,
         mop_finalize,
         mop_addref,
    -    mop_copy
    +    mop_copy,
    +    mop_move
       );
       tmanagementoperators=set of tmanagementoperator;
     
    diff --git a/compiler/symtable.pas b/compiler/symtable.pas
    index 305d39904a..4d4d6d82ad 100644
    --- a/compiler/symtable.pas
    +++ b/compiler/symtable.pas
    @@ -458,6 +458,7 @@ interface
         { _OP_FINALIZE   }  'finalize',
         { _OP_ADDREF     }  'addref',
         { _OP_COPY       }  'copy',
    +    { _OP_MOVE       }  'move',
         { _OP_INC        }  'inc',
         { _OP_DEC        }  'dec');
     
    @@ -466,7 +467,8 @@ interface
         { mop_initialize }  _OP_INITIALIZE,
         { mop_finalize   }  _OP_FINALIZE,
         { mop_addref     }  _OP_ADDREF,
    -    { mop_copy       }  _OP_COPY
    +    { mop_copy       }  _OP_COPY,
    +    { mop_move       }  _OP_MOVE
         );
     
     
    diff --git a/compiler/tokens.pas b/compiler/tokens.pas
    index e208e6bbd8..2cceab0171 100644
    --- a/compiler/tokens.pas
    +++ b/compiler/tokens.pas
    @@ -60,6 +60,7 @@ type
         _OP_FINALIZE,
         _OP_ADDREF,
         _OP_COPY,
    +    _OP_MOVE,
         _OP_INC,
         _OP_DEC,
         { special chars }
    @@ -141,6 +142,7 @@ type
         _FILE,
         _GOTO,
         _HUGE,
    +    _MOVE,
         _NAME,
         _NEAR,
         _READ,
    @@ -337,7 +339,7 @@ const
       last_overloaded  = _OP_DEC;
       last_operator = _GENERICSPECIALTOKEN;
       first_managment_operator = _OP_INITIALIZE;
    -  last_managment_operator = _OP_COPY;
    +  last_managment_operator = _OP_MOVE;
     
       highest_precedence = oppower;
     
    @@ -401,6 +403,7 @@ const
           (str:'finalize'      ;special:true ;keyword:[m_none];op:NOTOKEN),
           (str:'addref'        ;special:true ;keyword:[m_none];op:NOTOKEN),
           (str:'copy'          ;special:true ;keyword:[m_none];op:NOTOKEN),
    +      (str:'move'          ;special:true ;keyword:[m_none];op:NOTOKEN),
           (str:'inc'           ;special:true ;keyword:[m_none];op:NOTOKEN),
           (str:'dec'           ;special:true ;keyword:[m_none];op:NOTOKEN),
         { Special chars }
    @@ -482,6 +485,7 @@ const
           (str:'FILE'          ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
           (str:'GOTO'          ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
           (str:'HUGE'          ;special:false;keyword:[m_none];op:NOTOKEN),
    +      (str:'MOVE'          ;special:false;keyword:[m_none];op:NOTOKEN),
           (str:'NAME'          ;special:false;keyword:[m_none];op:NOTOKEN),
           (str:'NEAR'          ;special:false;keyword:[m_none];op:NOTOKEN),
           (str:'READ'          ;special:false;keyword:[m_none];op:NOTOKEN),
    diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc
    index 4bb4e8937b..6ec67746aa 100644
    --- a/rtl/inc/compproc.inc
    +++ b/rtl/inc/compproc.inc
    @@ -743,7 +743,9 @@ procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); compilerp
     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;
    +Function fpc_Move (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc;
     Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
    +Procedure fpc_Move_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
     {$endif FPC_HAS_FEATURE_RTTI}
     
     
    diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc
    index 46cae4c2dd..e0da4ad8a7 100644
    --- a/rtl/inc/rtti.inc
    +++ b/rtl/inc/rtti.inc
    @@ -104,6 +104,7 @@ begin
                   rotFinalize: hasManagementOp:=Assigned(RecordOp^.Finalize);
                   rotAddRef: hasManagementOp:=Assigned(RecordOp^.AddRef);
                   rotCopy: hasManagementOp:=Assigned(RecordOp^.Copy);
    +              rotMove: hasManagementOp:=Assigned(RecordOp^.Move);
                 end;
             end;
     {$else VER3_0}
    @@ -451,6 +452,136 @@ begin
       fpc_copy_internal(src,dest,typeinfo);
     end;
     
    +{ define alias for internal use in the system unit }
    +Function fpc_Move_internal (Src, Dest, TypeInfo : Pointer) : SizeInt;[external name 'FPC_MOVE'];
    +
    +Function fpc_Move (Src, Dest, TypeInfo : Pointer) : SizeInt;[Public,alias : 'FPC_MOVE']; compilerproc;
    +var
    +  Temp: pbyte;
    +  copiedsize,
    +  expectedoffset,
    +  count,
    +  offset,
    +  i: SizeInt;
    +  info: pointer;
    +begin
    +  result:=sizeof(pointer);
    +  case PTypeKind(TypeInfo)^ of
    +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
    +    tkAstring:
    +      fpc_AnsiStr_Assign(PPointer(Dest)^,PPointer(Src)^);
    +{$endif FPC_HAS_FEATURE_ANSISTRINGS}
    +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
    +  {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
    +    tkWstring:
    +      fpc_WideStr_Assign(PPointer(Dest)^,PPointer(Src)^);
    +  {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
    +    tkUstring:
    +      fpc_UnicodeStr_Assign(PPointer(Dest)^,PPointer(Src)^);
    +{$endif FPC_HAS_FEATURE_WIDESTRINGS}
    +    tkArray:
    +      begin
    +{$ifdef VER3_0}
    +        Temp:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
    +{$else VER3_0}
    +        Temp:=aligntoqword(typeInfo+2+PByte(typeInfo)[1]);
    +{$endif VER3_0}
    +      {$ifdef VER2_6}
    +        { Process elements }
    +        for I:=0 to PArrayInfo(Temp)^.ElCount-1 do
    +          fpc_Copy_internal(Src+(I*PArrayInfo(Temp)^.Size),Dest+(I*PArrayInfo(Temp)^.Size),PArrayInfo(Temp)^.ElInfo);
    +        Result:=PArrayInfo(Temp)^.Size*PArrayInfo(Temp)^.ElCount;
    +      {$else}
    +        Result:=PArrayInfo(Temp)^.Size;
    +        Count:=PArrayInfo(Temp)^.ElCount;
    +        { no elements to process => exit }
    +        if Count = 0 then
    +          Exit;
    +        Info:=PArrayInfo(Temp)^.ElInfo{$ifndef VER3_0}^{$endif};
    +        copiedsize:=Result div Count;
    +        Offset:=0;
    +        { Process elements }
    +        for I:=1 to Count do
    +          begin
    +            fpc_Copy_internal(Src+Offset,Dest+Offset,Info);
    +            inc(Offset,copiedsize);
    +          end;
    +      {$endif}
    +      end;
    +{$ifdef FPC_HAS_FEATURE_OBJECTS}
    +    tkobject,
    +{$endif FPC_HAS_FEATURE_OBJECTS}
    +    tkrecord:
    +{$ifndef VER3_0}
    +      { find init table }
    +      with RTTIRecordOp(typeinfo, typeinfo)^ do
    +{$endif VER3_0}
    +      begin
    +{$ifdef VER3_0}
    +        typeInfo:=RTTIRecordRttiInfoToInitInfo(typeInfo);
    +        Temp:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
    +{$else VER3_0}
    +        Temp:=aligntoqword(typeInfo+2+PByte(typeInfo)[1]);
    +{$endif VER3_0}
    +{$ifndef VER3_0}
    +        { during move operations the move operator takes precedence
    +          over the copy operator and finally if either operator is
    +          not present then standard memory move is used }
    +        if Assigned(recordop) and Assigned(recordop^.Move) then
    +          recordop^.Move(Src,Dest)
    +        else if Assigned(recordop) and Assigned(recordop^.Copy) then
    +          recordop^.Copy(Src,Dest)
    +        else
    +          begin
    +            Result:=Size;
    +            Inc(PRecordInfoInit(Temp));
    +{$else VER3_0}
    +            Result:=PRecordInfoFull(Temp)^.Size;
    +            Count:=PRecordInfoFull(Temp)^.Count;
    +            Inc(PRecordInfoFull(Temp));
    +{$endif VER3_0}
    +            expectedoffset:=0;
    +            { Process elements with rtti }
    +            for i:=1 to Count Do
    +              begin
    +                Info:=PRecordElement(Temp)^.TypeInfo{$ifndef VER3_0}^{$endif};
    +                Offset:=PRecordElement(Temp)^.Offset;
    +                Inc(PRecordElement(Temp));
    +                if Offset>expectedoffset then
    +                  move((Src+expectedoffset)^,(Dest+expectedoffset)^,Offset-expectedoffset);
    +                copiedsize:=fpc_Move_internal(Src+Offset,Dest+Offset,Info);
    +                expectedoffset:=Offset+copiedsize;
    +              end;
    +            { elements remaining? }
    +            if result>expectedoffset then
    +              move((Src+expectedoffset)^,(Dest+expectedoffset)^,Result-expectedoffset);
    +{$ifndef VER3_0}
    +          end;
    +{$endif VER3_0}
    +      end;
    +{$ifdef FPC_HAS_FEATURE_DYNARRAYS}
    +    tkDynArray:
    +      fpc_dynarray_assign(PPointer(Dest)^,PPointer(Src)^,typeinfo);
    +{$endif FPC_HAS_FEATURE_DYNARRAYS}
    +    tkInterface:
    +      fpc_intf_assign(PPointer(Dest)^,PPointer(Src)^);
    +{$ifdef FPC_HAS_FEATURE_VARIANTS}
    +    tkVariant:
    +      begin
    +        VarCopyProc(pvardata(dest)^,pvardata(src)^);
    +        result:=sizeof(tvardata);
    +      end;
    +{$endif FPC_HAS_FEATURE_VARIANTS}
    +  end;
    +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                                               }
    +procedure fpc_Move_proc (Src, Dest, TypeInfo : Pointer);compilerproc; inline;
    +begin
    +  fpc_move_internal(src,dest,typeinfo);
    +end;
     
     procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); [public,alias:'FPC_INITIALIZE_ARRAY']; compilerproc;
       var
    diff --git a/rtl/inc/rttidecl.inc b/rtl/inc/rttidecl.inc
    index 55a4e6cfe6..a5135a9663 100644
    --- a/rtl/inc/rttidecl.inc
    +++ b/rtl/inc/rttidecl.inc
    @@ -79,7 +79,8 @@ type
     {$ifndef VER3_0}
       TRTTIRecVarOp=procedure(ARec: Pointer);
       TRTTIRecCopyOp=procedure(ASrc, ADest: Pointer);
    -  TRTTIRecOpType=(rotAny, rotInitialize, rotFinalize, rotAddRef, rotCopy);
    +  TRTTIRecMoveOp=procedure(ASrc, ADest: Pointer);
    +  TRTTIRecOpType=(rotAny, rotInitialize, rotFinalize, rotAddRef, rotCopy, rotMove);
       PRTTIRecordOpVMT=^TRTTIRecordOpVMT;
       TRTTIRecordOpVMT=
     {$ifdef USE_PACKED}
    @@ -90,6 +91,7 @@ type
         Finalize: TRTTIRecVarOp;
         AddRef: TRTTIRecVarOp;
         Copy: TRTTIRecCopyOp;
    +    Move: TRTTIRecMoveOp;
       end;
     
       TRTTIRecordOpOffsetEntry =
    diff --git a/tests/test/tmoveop1.pp b/tests/test/tmoveop1.pp
    new file mode 100644
    index 0000000000..3c1560676a
    --- /dev/null
    +++ b/tests/test/tmoveop1.pp
    @@ -0,0 +1,150 @@
    +{$mode objfpc}
    +{$modeswitch advancedrecords}
    +
    +program tmoveop1;
    +
    +type
    +  TCopyOperations = (op_copy, op_move, op_uknown);
    +var
    +  LastOperation: TCopyOperations;
    +
    +type
    +  TBase = record
    +    constructor Create(val: integer);
    +    class operator Copy(constref aSrc: TBase; var aDst: TBase);
    +    class operator Move(constref aSrc: TBase; var aDst: TBase);
    +  end;
    +  PBase = ^TBase;
    +  TBaseAlias = TBase;
    +
    +constructor TBase.Create(val: integer);
    +begin
    +end;
    +
    +class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
    +begin
    +  LastOperation := op_copy;
    +end;
    +
    +class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
    +begin
    +  LastOperation := op_move;
    +end;
    +
    +type
    +  TMyClass = class
    +    a: TBase;
    +    function GetBase: TBase;
    +    function GetBase_inline: TBase; inline;
    +    property a0: TBase read a;
    +    property a1: TBase read GetBase;
    +    property a2: TBase read GetBase_inline;
    +  end;
    +
    +function TMyClass.GetBase: TBase;
    +begin
    +  result := a;
    +end;
    +
    +function TMyClass.GetBase_inline: TBase;
    +begin
    +  result := a;
    +end;
    +
    +var
    +  gBase: TBase;
    +
    +function get_pbase: PBase;
    +begin
    +  result := @gBase;
    +end;
    +
    +function get_base: TBase;
    +begin
    +  result := gBase;
    +end;
    +
    +procedure FailIfNot(op: TCopyOperations);
    +begin
    +  if LastOperation <> op then
    +    begin
    +      writeln('FAILED! LastOperation=', LastOperation, ' should be ', op);
    +      halt(-1);
    +    end;
    +end;
    +
    +var
    +  a,b: TBase;
    +  p: PBase;
    +  r: array of TBase;
    +  c: TMyClass;
    +begin
    +
    +  { load nodes are always copies becase they point to static memory }
    +  LastOperation := op_uknown;
    +  a := b;
    +  FailIfNot(op_copy);
    +
    +  LastOperation := op_uknown;
    +  a := TBaseAlias(b);
    +  FailIfNot(op_copy);
    +
    +  { deref nodes always default to copy because we can't confirm at
    +    compile time that they point to temporary memory or not }
    +  LastOperation := op_uknown;
    +  a := get_pbase^;
    +  FailIfNot(op_copy);
    +
    +  LastOperation := op_uknown;
    +  a := pbase(@get_base)^;
    +  FailIfNot(op_copy);
    +
    +  { call nodes are a move operation because the function is always 
    +    copy-on-pass in pascal }
    +  LastOperation := op_uknown;
    +  a := get_base;
    +  FailIfNot(op_move);
    +
    +  { constructors are call nodes so same rules apply }
    +  LastOperation := op_uknown;
    +  a := TBase.Create(1);
    +  FailIfNot(op_move);
    +
    +  { dynamic arrays - same rules apply as normal assignments }
    +  LastOperation := op_uknown;
    +  r := [a];
    +  FailIfNot(op_copy);
    +
    +  { dynamic arrays - same rules apply as normal assignments }
    +  LastOperation := op_uknown;
    +  r := [TBase.Create(1)];
    +  FailIfNot(op_move);
    +
    +  { vector nodes always default to copy because we can't confirm at
    +    compile time that they point to temporary memory or not }
    +  LastOperation := op_uknown;
    +  a := r[0];
    +  FailIfNot(op_copy);
    +
    +  { subscript node to field is static memory }
    +  c := TMyClass.Create;
    +  LastOperation := op_uknown;
    +  a := c.a;
    +  FailIfNot(op_copy);
    +
    +  { read property is fieldvarsym which is static memory }
    +  LastOperation := op_uknown;
    +  a := c.a0;
    +  FailIfNot(op_copy);
    +
    +  { read property with getter function is call node and temporary }
    +  LastOperation := op_uknown;
    +  a := c.a1;
    +  FailIfNot(op_move);
    +
    +  { read property with getter function is inlined so it maps
    +    directly to a field and should be a copy }
    +  LastOperation := op_uknown;
    +  a := c.a2;
    +  FailIfNot(op_copy);
    +end.
    diff --git a/tests/test/tmoveop2.pp b/tests/test/tmoveop2.pp
    new file mode 100644
    index 0000000000..9c57e06106
    --- /dev/null
    +++ b/tests/test/tmoveop2.pp
    @@ -0,0 +1,31 @@
    +{$mode objfpc}
    +{$modeswitch advancedrecords}
    +
    +program tmoveop2;
    +
    +type
    +  TBase = record
    +    constructor Create(val: integer);
    +    class operator Copy(constref aSrc: TBase; var aDst: TBase);
    +  end;
    +
    +var
    +  CopyCalled: boolean = false;
    +
    +constructor TBase.Create(val: integer);
    +begin
    +end;
    +
    +class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
    +begin
    +  CopyCalled := true;
    +end;
    +
    +var
    +  a: TBase;
    +begin
    +  // the move operator is not implemented so copy operator is used
    +  a := TBase.Create(1);
    +  if not CopyCalled then
    +    Halt(-1);
    +end.
    diff --git a/tests/test/tmoveop3.pp b/tests/test/tmoveop3.pp
    new file mode 100644
    index 0000000000..e18aa42771
    --- /dev/null
    +++ b/tests/test/tmoveop3.pp
    @@ -0,0 +1,42 @@
    +{$mode objfpc}
    +{$modeswitch advancedrecords}
    +
    +program tmoveop3;
    +
    +type
    +  TBase = record
    +    class operator Move(constref aSrc: TBase; var aDst: TBase);
    +  end;
    +
    +type
    +  TMyRecord = record
    +    field1: TBase;
    +    field2: TBase;
    +    constructor Create(num: integer);
    +  end;
    +
    +var
    +  MoveCalls: integer = 0;
    +
    +class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
    +begin
    +  MoveCalls += 1;
    +end;
    +
    +constructor TMyRecord.Create(num: integer);
    +begin
    +end;
    +
    +var
    +  a: TMyRecord;
    +begin
    +  a := TMyRecord.Create(0);
    +  { TMyRecord doesn't implement Move but the 2 nested record
    +    fields of type TBase do implement Move so we should get
    +    2 move calls. }
    +  if MoveCalls <> 2 then
    +    begin
    +      writeln('Failed!');
    +      Halt(-1);
    +    end;
    +end.
    \ No newline at end of file
    diff --git a/tests/test/tmoveop4.pp b/tests/test/tmoveop4.pp
    new file mode 100644
    index 0000000000..a513466416
    --- /dev/null
    +++ b/tests/test/tmoveop4.pp
    @@ -0,0 +1,53 @@
    +{$mode objfpc}
    +{$modeswitch advancedrecords}
    +
    +program tmoveop4;
    +
    +type
    +  TBase = record
    +    num: integer;
    +    class operator Move(constref aSrc: TBase; var aDst: TBase);
    +  end;
    +
    +type
    +  TChild = record
    +    base: TBase;
    +  end;
    +
    +type
    +  TMyRecord = record
    +    field1: TChild;
    +    field2: TChild;
    +    constructor Create(num: integer);
    +  end;
    +
    +var
    +  MoveCalls: integer = 0;
    +
    +class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
    +begin
    +  MoveCalls += 1;
    +  aDst.num := aSrc.num;
    +end;
    +
    +constructor TMyRecord.Create(num: integer);
    +begin
    +  field1.base.num := num;
    +  field2.base.num := num;
    +end;
    +
    +const
    +  kValue = 10;
    +var
    +  a: TMyRecord;
    +begin
    +  a := TMyRecord.Create(kValue);
    +  { TMyRecord doesn't implement Move but the 2 nested record
    +    fields of type TBase do implement Move so we should get
    +    2 move calls. }
    +  if (MoveCalls <> 2) or (a.field1.base.num <> kValue) or (a.field2.base.num <> kValue) then
    +    begin
    +      writeln('Failed!');
    +      Halt(-1);
    +    end;
    +end.
    \ No newline at end of file
    -- 
    2.17.2 (Apple Git-113)
    
    
    patch_7_11.diff (25,437 bytes)

Relationships

has duplicate 0035823 resolvedSven Barth [PATCH] Move management operator 

Activities

Ryan Joseph

2019-07-10 22:29

reporter  

moveop_7_9.diff (21,686 bytes)
From fc07e6d9ed4ace42d4a100a4a4b439794e09b128 Mon Sep 17 00:00:00 2001
From: Ryan Joseph <genericptr@gmail.com>
Date: Sat, 15 Jun 2019 10:48:30 -0400
Subject: [PATCH] Move management operator

---
 .gitignore             |  24 +++++++
 compiler/htypechk.pas  |   5 +-
 compiler/ncal.pas      |   5 ++
 compiler/nld.pas       |   8 ++-
 compiler/nmem.pas      |  24 ++++++-
 compiler/node.pas      |  24 ++++++-
 compiler/pdecsub.pas   |   5 +-
 compiler/symconst.pas  |   3 +-
 compiler/symtable.pas  |   4 +-
 compiler/tokens.pas    |   6 +-
 rtl/inc/compproc.inc   |   2 +
 rtl/inc/rtti.inc       |  72 ++++++++++++++++++++
 rtl/inc/rttidecl.inc   |   4 +-
 tests/test/tmoveop1.pp | 150 +++++++++++++++++++++++++++++++++++++++++
 tests/test/tmoveop2.pp |  31 +++++++++
 15 files changed, 356 insertions(+), 11 deletions(-)
 create mode 100644 .gitignore
 create mode 100644 tests/test/tmoveop1.pp
 create mode 100644 tests/test/tmoveop2.pp

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000000..8b577f31db
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,24 @@
+# files
+pp
+fpmake
+rtl/darwin/fpcmade.x86_64-darwin
+fpmake_proc1 copy.inc
+tests/*.x86_64-darwin
+rtl/Package.fpc
+tests/createlst
+tests/gparmake
+#compiler/ryan_ppcx64.lpi
+
+# directories
+lazbuild/
+x86_64-darwin/
+tests/tstunits/
+tests/utils
+
+# patterns
+*.app
+*.o
+*.ppu
+*.fpm
+*.rsj
+*.lst
\ No newline at end of file
diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
index 2a9f378f75..f84bbe9004 100644
--- a/compiler/htypechk.pas
+++ b/compiler/htypechk.pas
@@ -142,12 +142,13 @@ interface
         (tok:_OP_DEC     ;nod:inlinen;inr:in_dec_x;op_overloading_supported:true;minargs:1;maxargs:1)   { unary overloading supported }
       );
 
-      tok2ops=4;
+      tok2ops=5;
       tok2op: array[1..tok2ops] of ttok2oprec=(
         (tok:_OP_INITIALIZE; managementoperator: mop_initialize),
         (tok:_OP_FINALIZE  ; managementoperator: mop_finalize),
         (tok:_OP_ADDREF    ; managementoperator: mop_addref),
-        (tok:_OP_COPY      ; managementoperator: mop_copy)
+        (tok:_OP_COPY      ; managementoperator: mop_copy),
+        (tok:_OP_MOVE      ; managementoperator: mop_move)
       );
 
     function node2opstr(nt:tnodetype):string;
diff --git a/compiler/ncal.pas b/compiler/ncal.pas
index 546a1a0d99..e15471d44f 100644
--- a/compiler/ncal.pas
+++ b/compiler/ncal.pas
@@ -90,6 +90,7 @@ interface
           function  pass1_normal:tnode;
           procedure register_created_object_types;
           function get_expect_loc: tcgloc;
+          function memory_mapping : tnode_memory_mapping;override;
        protected
           function safe_call_self_node: tnode;
           procedure gen_vmt_entry_load; virtual;
@@ -2562,6 +2563,10 @@ implementation
           result:=LOC_REFERENCE
       end;
 
+    function tcallnode.memory_mapping : tnode_memory_mapping;
+      begin
+        result:=nmm_temporary;
+      end;
 
     function tcallnode.safe_call_self_node: tnode;
       begin
diff --git a/compiler/nld.pas b/compiler/nld.pas
index 65a82a13f1..b2a2b04bc0 100644
--- a/compiler/nld.pas
+++ b/compiler/nld.pas
@@ -779,6 +779,7 @@ implementation
         hdef: tdef;
         hs: string;
         needrtti: boolean;
+        st: tsymtable;
       begin
          result:=nil;
          expectloc:=LOC_VOID;
@@ -846,7 +847,12 @@ implementation
                ccallparanode.create(ctypeconvnode.create_internal(
                  caddrnode.create_internal(right),voidpointertype),
                nil)));
-           result:=ccallnode.createintern('fpc_copy_proc',hp);
+           { if the move operator is implemented it takes precedence over copy }
+           st:=tabstractrecorddef(left.resultdef).symtable;
+           if (mop_move in trecordsymtable(st).managementoperators) and (right.memory_mapping=nmm_temporary) then
+             result:=ccallnode.createintern('fpc_move_proc',hp)
+           else
+             result:=ccallnode.createintern('fpc_copy_proc',hp);
            firstpass(result);
            left:=nil;
            right:=nil;
diff --git a/compiler/nmem.pas b/compiler/nmem.pas
index ec36ceead6..28dcf026c2 100644
--- a/compiler/nmem.pas
+++ b/compiler/nmem.pas
@@ -105,6 +105,7 @@ interface
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           procedure mark_write;override;
+          function memory_mapping : tnode_memory_mapping;override;
        end;
        tderefnodeclass = class of tderefnode;
 
@@ -133,6 +134,7 @@ interface
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           procedure mark_write;override;
+          function memory_mapping : tnode_memory_mapping;override;
        end;
        tvecnodeclass = class of tvecnode;
 
@@ -766,6 +768,11 @@ implementation
       include(flags,nf_write);
     end;
 
+    function Tderefnode.memory_mapping : tnode_memory_mapping;
+      begin
+        result:=nmm_static;
+      end;
+
     function tderefnode.pass_1 : tnode;
       begin
          result:=nil;
@@ -851,7 +858,6 @@ implementation
           left.mark_write;
       end;
 
-
     function tsubscriptnode.pass_1 : tnode;
       begin
          result:=nil;
@@ -1163,6 +1169,22 @@ implementation
       end;
 
 
+    function tvecnode.memory_mapping : tnode_memory_mapping;
+      begin
+        // TODO: if right is a constant and left is constant array we should in therory
+        // be able to determine at compile time if the value is mapped or not
+        if is_array_constructor(left.resultdef) or
+           is_dynamic_array(left.resultdef) or
+           is_open_array(left.resultdef) and
+           is_ordinal(right.resultdef) then
+          begin
+            result:=inherited memory_mapping;
+          end
+        else
+          result:=left.memory_mapping;
+      end;
+
+
     function tvecnode.pass_1 : tnode;
       begin
          result:=nil;
diff --git a/compiler/node.pas b/compiler/node.pas
index a0aad228eb..609354a1af 100644
--- a/compiler/node.pas
+++ b/compiler/node.pas
@@ -295,6 +295,14 @@ interface
        tnodelist = class
        end;
 
+      tnode_memory_mapping = (  { no memory mapping was explicitly given for the node (the default) }
+                                nmm_unspecified,  
+                                { the node maps to static (e.g. addressable) memory }
+                                nmm_static,       
+                                { the node maps to temporary memory (e.g. the address can not be gotten using @) }
+                                nmm_temporary     
+                             );
+
       pnode = ^tnode;
       { basic class for the intermediated representation fpc uses }
       tnode = class
@@ -385,6 +393,7 @@ interface
          procedure printnodetree(var t:text);virtual;
          procedure concattolist(l : tlinkedlist);virtual;
          function ischild(p : tnode) : boolean;virtual;
+         function memory_mapping : tnode_memory_mapping;virtual;
 
          { ensures that the optimizer info record is allocated }
          function allocoptinfo : poptinfo;inline;
@@ -409,6 +418,7 @@ interface
          procedure derefimpl;override;
          procedure concattolist(l : tlinkedlist);override;
          function ischild(p : tnode) : boolean;override;
+         function memory_mapping : tnode_memory_mapping;override;
          function docompare(p : tnode) : boolean;override;
          function dogetcopy : tnode;override;
          procedure insertintolist(l : tnodelist);override;
@@ -846,6 +856,12 @@ implementation
       end;
 
 
+    function tnode.memory_mapping : tnode_memory_mapping;
+      begin
+        result:=nmm_unspecified;
+      end;
+
+
     procedure tnode.mark_write;
       begin
 {$ifdef EXTDEBUG}
@@ -1072,6 +1088,13 @@ implementation
          ischild:=p=left;
       end;
 
+    function tunarynode.memory_mapping : tnode_memory_mapping;
+      begin
+        if assigned(left) then
+          result:=left.memory_mapping
+        else
+          result:=inherited memory_mapping;
+      end;
 
 {****************************************************************************
                             TBINARYNODE
@@ -1138,7 +1161,6 @@ implementation
          ischild:=(p=right);
       end;
 
-
     function tbinarynode.docompare(p : tnode) : boolean;
       begin
          docompare:=(inherited docompare(p) and
diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
index d600583fef..295ad90154 100644
--- a/compiler/pdecsub.pas
+++ b/compiler/pdecsub.pas
@@ -572,6 +572,7 @@ implementation
                     _FINALIZE:optoken:=_OP_FINALIZE;
                     _ADDREF:optoken:=_OP_ADDREF;
                     _COPY:optoken:=_OP_COPY;
+                    _MOVE:optoken:=_OP_MOVE;
                     else
                     if (m_delphi in current_settings.modeswitches) then
                       case lastidtoken of
@@ -1452,7 +1453,7 @@ implementation
                   consume(_ID);
                 end;
               { operators without result (management operators) }
-              if optoken in [_OP_INITIALIZE, _OP_FINALIZE, _OP_ADDREF, _OP_COPY] then
+              if optoken in [_OP_INITIALIZE,_OP_FINALIZE,_OP_ADDREF,_OP_COPY,_OP_MOVE] then
                 begin
                   { single var parameter to point the record }
                   if (optoken in [_OP_INITIALIZE, _OP_FINALIZE, _OP_ADDREF]) and
@@ -1463,7 +1464,7 @@ implementation
                      ) then
                     Message(parser_e_overload_impossible)
                   { constref (source) and var (dest) parameter to point the records }
-                  else if (optoken=_OP_COPY) and
+                  else if (optoken in [_OP_COPY,_OP_MOVE]) and
                      (
                       (pd.parast.SymList.Count<>2) or
                       (tparavarsym(pd.parast.SymList[0]).vardef<>pd.struct) or
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index 5904dbeac7..1f76000f0d 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -610,7 +610,8 @@ type
     mop_initialize,
     mop_finalize,
     mop_addref,
-    mop_copy
+    mop_copy,
+    mop_move
   );
   tmanagementoperators=set of tmanagementoperator;
 
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index 305d39904a..4d4d6d82ad 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -458,6 +458,7 @@ interface
     { _OP_FINALIZE   }  'finalize',
     { _OP_ADDREF     }  'addref',
     { _OP_COPY       }  'copy',
+    { _OP_MOVE       }  'move',
     { _OP_INC        }  'inc',
     { _OP_DEC        }  'dec');
 
@@ -466,7 +467,8 @@ interface
     { mop_initialize }  _OP_INITIALIZE,
     { mop_finalize   }  _OP_FINALIZE,
     { mop_addref     }  _OP_ADDREF,
-    { mop_copy       }  _OP_COPY
+    { mop_copy       }  _OP_COPY,
+    { mop_move       }  _OP_MOVE
     );
 
 
diff --git a/compiler/tokens.pas b/compiler/tokens.pas
index e208e6bbd8..2cceab0171 100644
--- a/compiler/tokens.pas
+++ b/compiler/tokens.pas
@@ -60,6 +60,7 @@ type
     _OP_FINALIZE,
     _OP_ADDREF,
     _OP_COPY,
+    _OP_MOVE,
     _OP_INC,
     _OP_DEC,
     { special chars }
@@ -141,6 +142,7 @@ type
     _FILE,
     _GOTO,
     _HUGE,
+    _MOVE,
     _NAME,
     _NEAR,
     _READ,
@@ -337,7 +339,7 @@ const
   last_overloaded  = _OP_DEC;
   last_operator = _GENERICSPECIALTOKEN;
   first_managment_operator = _OP_INITIALIZE;
-  last_managment_operator = _OP_COPY;
+  last_managment_operator = _OP_MOVE;
 
   highest_precedence = oppower;
 
@@ -401,6 +403,7 @@ const
       (str:'finalize'      ;special:true ;keyword:[m_none];op:NOTOKEN),
       (str:'addref'        ;special:true ;keyword:[m_none];op:NOTOKEN),
       (str:'copy'          ;special:true ;keyword:[m_none];op:NOTOKEN),
+      (str:'move'          ;special:true ;keyword:[m_none];op:NOTOKEN),
       (str:'inc'           ;special:true ;keyword:[m_none];op:NOTOKEN),
       (str:'dec'           ;special:true ;keyword:[m_none];op:NOTOKEN),
     { Special chars }
@@ -482,6 +485,7 @@ const
       (str:'FILE'          ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
       (str:'GOTO'          ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
       (str:'HUGE'          ;special:false;keyword:[m_none];op:NOTOKEN),
+      (str:'MOVE'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'NAME'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'NEAR'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'READ'          ;special:false;keyword:[m_none];op:NOTOKEN),
diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc
index 4bb4e8937b..6ec67746aa 100644
--- a/rtl/inc/compproc.inc
+++ b/rtl/inc/compproc.inc
@@ -743,7 +743,9 @@ procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); compilerp
 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;
+Function fpc_Move (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc;
 Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
+Procedure fpc_Move_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
 {$endif FPC_HAS_FEATURE_RTTI}
 
 
diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc
index 46cae4c2dd..cda4fe4c07 100644
--- a/rtl/inc/rtti.inc
+++ b/rtl/inc/rtti.inc
@@ -104,6 +104,7 @@ begin
               rotFinalize: hasManagementOp:=Assigned(RecordOp^.Finalize);
               rotAddRef: hasManagementOp:=Assigned(RecordOp^.AddRef);
               rotCopy: hasManagementOp:=Assigned(RecordOp^.Copy);
+              rotMove: hasManagementOp:=Assigned(RecordOp^.Move);
             end;
         end;
 {$else VER3_0}
@@ -451,6 +452,77 @@ begin
   fpc_copy_internal(src,dest,typeinfo);
 end;
 
+{ define alias for internal use in the system unit }
+Function fpc_Move_internal (Src, Dest, TypeInfo : Pointer) : SizeInt;[external name 'FPC_MOVE'];
+
+Function fpc_Move (Src, Dest, TypeInfo : Pointer) : SizeInt;[Public,alias : 'FPC_MOVE']; compilerproc;
+var
+  Temp: pbyte;
+  copiedsize,
+  expectedoffset,
+  count,
+  offset,
+  i: SizeInt;
+  info: pointer;
+begin
+  result:=sizeof(pointer);
+  case PTypeKind(TypeInfo)^ of
+{$ifdef FPC_HAS_FEATURE_OBJECTS}
+    tkobject,
+{$endif FPC_HAS_FEATURE_OBJECTS}
+    tkrecord:
+{$ifndef VER3_0}
+      { find init table }
+      with RTTIRecordOp(typeinfo, typeinfo)^ do
+{$endif VER3_0}
+      begin
+{$ifdef VER3_0}
+        typeInfo:=RTTIRecordRttiInfoToInitInfo(typeInfo);
+        Temp:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
+{$else VER3_0}
+        Temp:=aligntoqword(typeInfo+2+PByte(typeInfo)[1]);
+{$endif VER3_0}
+{$ifndef VER3_0}
+        if Assigned(recordop) and Assigned(recordop^.Move) then
+          recordop^.Move(Src,Dest)
+        else
+          begin
+            Result:=Size;
+            Inc(PRecordInfoInit(Temp));
+{$else VER3_0}
+            Result:=PRecordInfoFull(Temp)^.Size;
+            Count:=PRecordInfoFull(Temp)^.Count;
+            Inc(PRecordInfoFull(Temp));
+{$endif VER3_0}
+            expectedoffset:=0;
+            { Process elements with rtti }
+            for i:=1 to Count Do
+              begin
+                Info:=PRecordElement(Temp)^.TypeInfo{$ifndef VER3_0}^{$endif};
+                Offset:=PRecordElement(Temp)^.Offset;
+                Inc(PRecordElement(Temp));
+                if Offset>expectedoffset then
+                  move((Src+expectedoffset)^,(Dest+expectedoffset)^,Offset-expectedoffset);
+                copiedsize:=fpc_Move_internal(Src+Offset,Dest+Offset,Info);
+                expectedoffset:=Offset+copiedsize;
+              end;
+            { elements remaining? }
+            if result>expectedoffset then
+              move((Src+expectedoffset)^,(Dest+expectedoffset)^,Result-expectedoffset);
+{$ifndef VER3_0}
+          end;
+{$endif VER3_0}
+      end;
+  end;
+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                                               }
+procedure fpc_Move_proc (Src, Dest, TypeInfo : Pointer);compilerproc; inline;
+begin
+  fpc_move_internal(src,dest,typeinfo);
+end;
 
 procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); [public,alias:'FPC_INITIALIZE_ARRAY']; compilerproc;
   var
diff --git a/rtl/inc/rttidecl.inc b/rtl/inc/rttidecl.inc
index 55a4e6cfe6..a5135a9663 100644
--- a/rtl/inc/rttidecl.inc
+++ b/rtl/inc/rttidecl.inc
@@ -79,7 +79,8 @@ type
 {$ifndef VER3_0}
   TRTTIRecVarOp=procedure(ARec: Pointer);
   TRTTIRecCopyOp=procedure(ASrc, ADest: Pointer);
-  TRTTIRecOpType=(rotAny, rotInitialize, rotFinalize, rotAddRef, rotCopy);
+  TRTTIRecMoveOp=procedure(ASrc, ADest: Pointer);
+  TRTTIRecOpType=(rotAny, rotInitialize, rotFinalize, rotAddRef, rotCopy, rotMove);
   PRTTIRecordOpVMT=^TRTTIRecordOpVMT;
   TRTTIRecordOpVMT=
 {$ifdef USE_PACKED}
@@ -90,6 +91,7 @@ type
     Finalize: TRTTIRecVarOp;
     AddRef: TRTTIRecVarOp;
     Copy: TRTTIRecCopyOp;
+    Move: TRTTIRecMoveOp;
   end;
 
   TRTTIRecordOpOffsetEntry =
diff --git a/tests/test/tmoveop1.pp b/tests/test/tmoveop1.pp
new file mode 100644
index 0000000000..3c1560676a
--- /dev/null
+++ b/tests/test/tmoveop1.pp
@@ -0,0 +1,150 @@
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+program tmoveop1;
+
+type
+  TCopyOperations = (op_copy, op_move, op_uknown);
+var
+  LastOperation: TCopyOperations;
+
+type
+  TBase = record
+    constructor Create(val: integer);
+    class operator Copy(constref aSrc: TBase; var aDst: TBase);
+    class operator Move(constref aSrc: TBase; var aDst: TBase);
+  end;
+  PBase = ^TBase;
+  TBaseAlias = TBase;
+
+constructor TBase.Create(val: integer);
+begin
+end;
+
+class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
+begin
+  LastOperation := op_copy;
+end;
+
+class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
+begin
+  LastOperation := op_move;
+end;
+
+type
+  TMyClass = class
+    a: TBase;
+    function GetBase: TBase;
+    function GetBase_inline: TBase; inline;
+    property a0: TBase read a;
+    property a1: TBase read GetBase;
+    property a2: TBase read GetBase_inline;
+  end;
+
+function TMyClass.GetBase: TBase;
+begin
+  result := a;
+end;
+
+function TMyClass.GetBase_inline: TBase;
+begin
+  result := a;
+end;
+
+var
+  gBase: TBase;
+
+function get_pbase: PBase;
+begin
+  result := @gBase;
+end;
+
+function get_base: TBase;
+begin
+  result := gBase;
+end;
+
+procedure FailIfNot(op: TCopyOperations);
+begin
+  if LastOperation <> op then
+    begin
+      writeln('FAILED! LastOperation=', LastOperation, ' should be ', op);
+      halt(-1);
+    end;
+end;
+
+var
+  a,b: TBase;
+  p: PBase;
+  r: array of TBase;
+  c: TMyClass;
+begin
+
+  { load nodes are always copies becase they point to static memory }
+  LastOperation := op_uknown;
+  a := b;
+  FailIfNot(op_copy);
+
+  LastOperation := op_uknown;
+  a := TBaseAlias(b);
+  FailIfNot(op_copy);
+
+  { deref nodes always default to copy because we can't confirm at
+    compile time that they point to temporary memory or not }
+  LastOperation := op_uknown;
+  a := get_pbase^;
+  FailIfNot(op_copy);
+
+  LastOperation := op_uknown;
+  a := pbase(@get_base)^;
+  FailIfNot(op_copy);
+
+  { call nodes are a move operation because the function is always 
+    copy-on-pass in pascal }
+  LastOperation := op_uknown;
+  a := get_base;
+  FailIfNot(op_move);
+
+  { constructors are call nodes so same rules apply }
+  LastOperation := op_uknown;
+  a := TBase.Create(1);
+  FailIfNot(op_move);
+
+  { dynamic arrays - same rules apply as normal assignments }
+  LastOperation := op_uknown;
+  r := [a];
+  FailIfNot(op_copy);
+
+  { dynamic arrays - same rules apply as normal assignments }
+  LastOperation := op_uknown;
+  r := [TBase.Create(1)];
+  FailIfNot(op_move);
+
+  { vector nodes always default to copy because we can't confirm at
+    compile time that they point to temporary memory or not }
+  LastOperation := op_uknown;
+  a := r[0];
+  FailIfNot(op_copy);
+
+  { subscript node to field is static memory }
+  c := TMyClass.Create;
+  LastOperation := op_uknown;
+  a := c.a;
+  FailIfNot(op_copy);
+
+  { read property is fieldvarsym which is static memory }
+  LastOperation := op_uknown;
+  a := c.a0;
+  FailIfNot(op_copy);
+
+  { read property with getter function is call node and temporary }
+  LastOperation := op_uknown;
+  a := c.a1;
+  FailIfNot(op_move);
+
+  { read property with getter function is inlined so it maps
+    directly to a field and should be a copy }
+  LastOperation := op_uknown;
+  a := c.a2;
+  FailIfNot(op_copy);
+end.
diff --git a/tests/test/tmoveop2.pp b/tests/test/tmoveop2.pp
new file mode 100644
index 0000000000..9c57e06106
--- /dev/null
+++ b/tests/test/tmoveop2.pp
@@ -0,0 +1,31 @@
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+program tmoveop2;
+
+type
+  TBase = record
+    constructor Create(val: integer);
+    class operator Copy(constref aSrc: TBase; var aDst: TBase);
+  end;
+
+var
+  CopyCalled: boolean = false;
+
+constructor TBase.Create(val: integer);
+begin
+end;
+
+class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
+begin
+  CopyCalled := true;
+end;
+
+var
+  a: TBase;
+begin
+  // the move operator is not implemented so copy operator is used
+  a := TBase.Create(1);
+  if not CopyCalled then
+    Halt(-1);
+end.
-- 
2.17.2 (Apple Git-113)

moveop_7_9.diff (21,686 bytes)

Akira1364

2019-07-10 22:32

reporter   ~0117144

You seem to have opened this issue twice, BTW.

Ryan Joseph

2019-07-10 22:38

reporter   ~0117145

There was an internet problem and I had to reload the page but it must have posted without telling me. If the admin sees this please delete the FIRST one since I cleaned up the code example the second time I inserted it.

Akira1364

2019-07-10 23:27

reporter   ~0117147

Last edited: 2019-07-10 23:28

View 2 revisions

One thing that stands out to me as strange (and I know you just adapted the behavior for "Move" from the existing implementation of the "Copy" methods, don't get me wrong) is all of the function / procedure aliasing going on in "rtti.inc".

For example, there's a comment that existed above "fpc_Copy_Proc", and now exists above "fpc_Move_Proc", that says:

{ 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 }

What is this even referring to, exactly? What would $X- have to do with anything there?

Further, why does the compiler call "compilerproc" procedures (which cannot be inlined despite being marked as such) that do nothing other than call the function versions of the relevant methods, which even more strangely recursively call "external" aliases of themselves?

Meaning, more specifically, for example:

Is there any *real* technical reason for "fpc_Copy_Proc" to exist? And why does "fpc_Copy" recursively call "fpc_Copy_Internal", which is just an alias for literally itself, instead of *actually* calling itself?

It seems like a strangely excessive amount of indirection overall, for no immediately obvious reason.

Sven Barth

2019-07-11 00:31

manager   ~0117150

@Akira1364:
Regarding your remarks there are multiple things involved:
1. Routines marked as "compilerproc" *can't* be called by normal code. Thus they need to be redeclared using a "external name ..." clause. If you look at the code this happens very often.
2. The existance of the *_proc routines is directly related to the comment you quoted. When the compiler directly calls the copy or move operator instead of using FPC_ASSIGN then it does not handle the result value, because it does not need to advance to any next field. However in $X- mode the result *must* be handled. Thus the *_proc routines which don't have a result value. (There's even a bug report from when this was added: 0009918)
3. If the *_proc routines (or compilerprocs in general) aren't inlined then this needs to be checked.

@Ryan:
- small remark: don't add the .gitignore file
- please also check for VER3_2 in the RTL nowadays as cycling with that needs to work as well; though you can completely hide the fpc_move and fpc_move proc using {$if not defined(VER3_0) and not defined(VER3_2)} as it won't be called by a 3.0 or 3.2 compiler anyway
- did you also test nested record hierarchies with various operator usages? E.g. a normal record with one with Move operator and one with Copy operator as children or a record with Move operator that has a record with Copy operator as child and so on?
- did you test with managed types (interfaces, strings, arrays, etc.) as fields? Cause I have the feeling that maybe you should simply call fpc_copy_internal (and do nothing else) if no move operator is set

Akira1364

2019-07-11 01:17

reporter   ~0117152

Last edited: 2019-07-11 01:18

View 2 revisions

@Sven:

Points one and two make sense, thanks.

As to the third, it may be that they *could* be inlined, but the compiler seems in all cases to explicitly build non-inline calls to them, such as seen here:

https://svn.freepascal.org/cgi-bin/viewvc.cgi/trunk/compiler/nld.pas?revision=42271&view=markup#l865

Ryan Joseph

2019-07-11 01:21

reporter   ~0117153

I'm not sure I got nested records correct, please respond to the comments below and tell me what you think. In practice since you know if the call was originated from a Move operator you can call a Move function for TBase but the := assignment will be a copy if you perform it like that. Personally I'm find with this before I still get control but maybe it's not ideal and could be fixed.

type
  TBase = record
    class operator Copy(constref aSrc: TBase; var aDst: TBase);
    class operator Move(constref aSrc: TBase; var aDst: TBase);
  end;

type
  TMyRecord = record
    field1: TBase;
    field2: TBase;
    class operator Copy(constref aSrc: TMyRecord; var aDst: TMyRecord);
    class operator Move(constref aSrc: TMyRecord; var aDst: TMyRecord);
  end;

class operator TMyRecord.Copy(constref aSrc: TMyRecord; var aDst: TMyRecord);
begin
  aDst.field1 := aSrc.field1;
  aDst.field2 := aSrc.field2;
end;

class operator TMyRecord.Move(constref aSrc: TMyRecord; var aDst: TMyRecord);
begin
  // Should these be moves or copies? currently they are copies becaus aSrc is addressable memory
  aDst.field1 := aSrc.field1;
  aDst.field2 := aSrc.field2;
end;

var
  a: TMyRecord;
begin
  // next line is a move followed by 2 copies.
  a := TMyRecord.Create;
end.

Ryan Joseph

2019-07-11 01:26

reporter   ~0117154

Here's another way to copy the nested fields, one with the copy operator and one with no operator (but should system.move call the move operator??).

class operator TMyRecord.Move(constref aSrc: TMyRecord; var aDst: TMyRecord);
begin
  { copy operator gets called }
  aDst.field1 := aSrc.field1;
  aDst.field2 := aSrc.field2;
  { fields are moved but *no* operator is called }
  System.Move(aSrc.field1, aDst.field1, sizeof(TBase));
  System.Move(aSrc.field2, aDst.field2, sizeof(TBase));
end;

Ryan Joseph

2019-07-11 01:30

reporter   ~0117155

As per ref counted types as fields not sure how to test. Here's a start if you want to add something:

program tmoveop4;

type
  TIntArray = array of integer;
  TMyRecord = record
    field1: TIntArray;
    field2: TIntArray;
    constructor Create(num: integer);
    class operator Move(constref aSrc: TMyRecord; var aDst: TMyRecord);
  end;

class operator TMyRecord.Move(constref aSrc: TMyRecord; var aDst: TMyRecord);
begin
  writeln('TMyRecord.Move ', HexStr(@aSrc), ' to ', HexStr(@aDst));
  aDst.field1 := aSrc.field1;
  aDst.field2 := aSrc.field2;
end;

constructor TMyRecord.Create(num: integer);
begin
  SetLength(field1, num);
  SetLength(field2, num);
end;

var
  a: TMyRecord;
begin
  a := TMyRecord.Create(10);
  writeln(length(a.field1));
  writeln(length(a.field2));

{
prints:
TMyRecord.Move 00007FFEEFBFF890 to 000000010003AAF0
10
10
 }

end.

Ryan Joseph

2019-07-11 01:37

reporter   ~0117156

I just looked at fpc_copy_internal in the RTL and I think you're right that I'm not actually doing a copy on the dynamic arrays. I'll need to either not call the move operator in this case or call the copy operator on other fields (this should be possible I think since we know their RTTI information). Not sure right now though, I need to look at this more tomorrow.

Ryan Joseph

2019-07-11 01:40

reporter   ~0117157

One more thing. I think I may just need to actually copy the rest of the code from fpc_copy into fpc_move so that other non-record fields are handled the same as in fpc_copy AND the copy operator needs to called on records that don't have the move operator. I think this can be done in fpc_move if I actually implemented it correctly this time.

Ryan Joseph

2019-07-11 03:04

reporter   ~0117159

Here's another test to consider. If TMyRecord doesn't have a move operator should the nested fields be moves anyways? I think I could fix this by calling fpc_move (even though there's no Move operator) and then implement fpc_move so it matches fpc_copy more closely. Let me think about this more tomorrow.

I'll get these things fixed later and add more tests. And btw my branch is at https://github.com/genericptr/freepascal/tree/moveop if you want to test.

program tmoveop5;

type
  TBase = record
    num: integer;
    class operator Copy(constref aSrc: TBase; var aDst: TBase);
    class operator Move(constref aSrc: TBase; var aDst: TBase);
  end;

type
  TMyRecord = record
    field1: TBase;
    field2: TBase;
    constructor Create(num: integer);
  end;

class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
begin
  writeln('TBase.Copy ', HexStr(@aSrc), ' to ', HexStr(@aDst));
  aDst.num := aSrc.num;
end;

class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
begin
  writeln('TBase.Move ', HexStr(@aSrc), ' to ', HexStr(@aDst));
  aDst.num := aSrc.num;
end;

constructor TMyRecord.Create(num: integer);
begin
  field1.num := num;
  field2.num := num;
end;

var
  a: TMyRecord;
begin
  a := TMyRecord.Create(10);
  writeln(a.field1.num);
  writeln(a.field2.num);
end.

output:

TBase.Copy 00007FFEEFBFF898 to 000000010003AAF0
TBase.Copy 00007FFEEFBFF89C to 000000010003AAF4
10
10

Ryan Joseph

2019-07-11 16:22

reporter   ~0117182

I made the changes so that nested records and ref counted types are handled by fpc_move now. The different is now fpc_move is always called for temporary memory assignments and fpc_move mimics fpc_copy with the exception that the Move operator takes precedence over the Copy operator.

@Sven, as per the checking for VER3_2 I didn't do this because you may want fpc_copy/fpc_move unified into one function now since fpc_move basically does everything fpc_copy does. Should I make another fpc_copy_internal that merges all this functionality and use a boolean parameter to specify whether Move takes precedence over Copy? Right now that's the only different between fpc_move and fpc_copy.

patch_7_11.diff (25,437 bytes)
From 2089842e5b393ff8e626d980804b8689b3251e75 Mon Sep 17 00:00:00 2001
From: Ryan Joseph <genericptr@gmail.com>
Date: Sat, 15 Jun 2019 10:48:30 -0400
Subject: [PATCH] Move operator

---
 compiler/htypechk.pas  |   5 +-
 compiler/ncal.pas      |   5 ++
 compiler/nld.pas       |   6 +-
 compiler/nmem.pas      |  24 ++++++-
 compiler/node.pas      |  24 ++++++-
 compiler/pdecsub.pas   |   5 +-
 compiler/symconst.pas  |   3 +-
 compiler/symtable.pas  |   4 +-
 compiler/tokens.pas    |   6 +-
 rtl/inc/compproc.inc   |   2 +
 rtl/inc/rtti.inc       | 131 +++++++++++++++++++++++++++++++++++
 rtl/inc/rttidecl.inc   |   4 +-
 tests/test/tmoveop1.pp | 150 +++++++++++++++++++++++++++++++++++++++++
 tests/test/tmoveop2.pp |  31 +++++++++
 tests/test/tmoveop3.pp |  42 ++++++++++++
 tests/test/tmoveop4.pp |  53 +++++++++++++++
 16 files changed, 484 insertions(+), 11 deletions(-)
 create mode 100644 tests/test/tmoveop1.pp
 create mode 100644 tests/test/tmoveop2.pp
 create mode 100644 tests/test/tmoveop3.pp
 create mode 100644 tests/test/tmoveop4.pp

diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
index 2a9f378f75..f84bbe9004 100644
--- a/compiler/htypechk.pas
+++ b/compiler/htypechk.pas
@@ -142,12 +142,13 @@ interface
         (tok:_OP_DEC     ;nod:inlinen;inr:in_dec_x;op_overloading_supported:true;minargs:1;maxargs:1)   { unary overloading supported }
       );
 
-      tok2ops=4;
+      tok2ops=5;
       tok2op: array[1..tok2ops] of ttok2oprec=(
         (tok:_OP_INITIALIZE; managementoperator: mop_initialize),
         (tok:_OP_FINALIZE  ; managementoperator: mop_finalize),
         (tok:_OP_ADDREF    ; managementoperator: mop_addref),
-        (tok:_OP_COPY      ; managementoperator: mop_copy)
+        (tok:_OP_COPY      ; managementoperator: mop_copy),
+        (tok:_OP_MOVE      ; managementoperator: mop_move)
       );
 
     function node2opstr(nt:tnodetype):string;
diff --git a/compiler/ncal.pas b/compiler/ncal.pas
index 546a1a0d99..e15471d44f 100644
--- a/compiler/ncal.pas
+++ b/compiler/ncal.pas
@@ -90,6 +90,7 @@ interface
           function  pass1_normal:tnode;
           procedure register_created_object_types;
           function get_expect_loc: tcgloc;
+          function memory_mapping : tnode_memory_mapping;override;
        protected
           function safe_call_self_node: tnode;
           procedure gen_vmt_entry_load; virtual;
@@ -2562,6 +2563,10 @@ implementation
           result:=LOC_REFERENCE
       end;
 
+    function tcallnode.memory_mapping : tnode_memory_mapping;
+      begin
+        result:=nmm_temporary;
+      end;
 
     function tcallnode.safe_call_self_node: tnode;
       begin
diff --git a/compiler/nld.pas b/compiler/nld.pas
index 65a82a13f1..0d870b4997 100644
--- a/compiler/nld.pas
+++ b/compiler/nld.pas
@@ -846,7 +846,11 @@ implementation
                ccallparanode.create(ctypeconvnode.create_internal(
                  caddrnode.create_internal(right),voidpointertype),
                nil)));
-           result:=ccallnode.createintern('fpc_copy_proc',hp);
+           { if the right node is temporary memory mapped then call move }
+           if right.memory_mapping=nmm_temporary then
+             result:=ccallnode.createintern('fpc_move_proc',hp)
+           else
+             result:=ccallnode.createintern('fpc_copy_proc',hp);
            firstpass(result);
            left:=nil;
            right:=nil;
diff --git a/compiler/nmem.pas b/compiler/nmem.pas
index ec36ceead6..28dcf026c2 100644
--- a/compiler/nmem.pas
+++ b/compiler/nmem.pas
@@ -105,6 +105,7 @@ interface
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           procedure mark_write;override;
+          function memory_mapping : tnode_memory_mapping;override;
        end;
        tderefnodeclass = class of tderefnode;
 
@@ -133,6 +134,7 @@ interface
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           procedure mark_write;override;
+          function memory_mapping : tnode_memory_mapping;override;
        end;
        tvecnodeclass = class of tvecnode;
 
@@ -766,6 +768,11 @@ implementation
       include(flags,nf_write);
     end;
 
+    function Tderefnode.memory_mapping : tnode_memory_mapping;
+      begin
+        result:=nmm_static;
+      end;
+
     function tderefnode.pass_1 : tnode;
       begin
          result:=nil;
@@ -851,7 +858,6 @@ implementation
           left.mark_write;
       end;
 
-
     function tsubscriptnode.pass_1 : tnode;
       begin
          result:=nil;
@@ -1163,6 +1169,22 @@ implementation
       end;
 
 
+    function tvecnode.memory_mapping : tnode_memory_mapping;
+      begin
+        // TODO: if right is a constant and left is constant array we should in therory
+        // be able to determine at compile time if the value is mapped or not
+        if is_array_constructor(left.resultdef) or
+           is_dynamic_array(left.resultdef) or
+           is_open_array(left.resultdef) and
+           is_ordinal(right.resultdef) then
+          begin
+            result:=inherited memory_mapping;
+          end
+        else
+          result:=left.memory_mapping;
+      end;
+
+
     function tvecnode.pass_1 : tnode;
       begin
          result:=nil;
diff --git a/compiler/node.pas b/compiler/node.pas
index a0aad228eb..609354a1af 100644
--- a/compiler/node.pas
+++ b/compiler/node.pas
@@ -295,6 +295,14 @@ interface
        tnodelist = class
        end;
 
+      tnode_memory_mapping = (  { no memory mapping was explicitly given for the node (the default) }
+                                nmm_unspecified,  
+                                { the node maps to static (e.g. addressable) memory }
+                                nmm_static,       
+                                { the node maps to temporary memory (e.g. the address can not be gotten using @) }
+                                nmm_temporary     
+                             );
+
       pnode = ^tnode;
       { basic class for the intermediated representation fpc uses }
       tnode = class
@@ -385,6 +393,7 @@ interface
          procedure printnodetree(var t:text);virtual;
          procedure concattolist(l : tlinkedlist);virtual;
          function ischild(p : tnode) : boolean;virtual;
+         function memory_mapping : tnode_memory_mapping;virtual;
 
          { ensures that the optimizer info record is allocated }
          function allocoptinfo : poptinfo;inline;
@@ -409,6 +418,7 @@ interface
          procedure derefimpl;override;
          procedure concattolist(l : tlinkedlist);override;
          function ischild(p : tnode) : boolean;override;
+         function memory_mapping : tnode_memory_mapping;override;
          function docompare(p : tnode) : boolean;override;
          function dogetcopy : tnode;override;
          procedure insertintolist(l : tnodelist);override;
@@ -846,6 +856,12 @@ implementation
       end;
 
 
+    function tnode.memory_mapping : tnode_memory_mapping;
+      begin
+        result:=nmm_unspecified;
+      end;
+
+
     procedure tnode.mark_write;
       begin
 {$ifdef EXTDEBUG}
@@ -1072,6 +1088,13 @@ implementation
          ischild:=p=left;
       end;
 
+    function tunarynode.memory_mapping : tnode_memory_mapping;
+      begin
+        if assigned(left) then
+          result:=left.memory_mapping
+        else
+          result:=inherited memory_mapping;
+      end;
 
 {****************************************************************************
                             TBINARYNODE
@@ -1138,7 +1161,6 @@ implementation
          ischild:=(p=right);
       end;
 
-
     function tbinarynode.docompare(p : tnode) : boolean;
       begin
          docompare:=(inherited docompare(p) and
diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
index d600583fef..295ad90154 100644
--- a/compiler/pdecsub.pas
+++ b/compiler/pdecsub.pas
@@ -572,6 +572,7 @@ implementation
                     _FINALIZE:optoken:=_OP_FINALIZE;
                     _ADDREF:optoken:=_OP_ADDREF;
                     _COPY:optoken:=_OP_COPY;
+                    _MOVE:optoken:=_OP_MOVE;
                     else
                     if (m_delphi in current_settings.modeswitches) then
                       case lastidtoken of
@@ -1452,7 +1453,7 @@ implementation
                   consume(_ID);
                 end;
               { operators without result (management operators) }
-              if optoken in [_OP_INITIALIZE, _OP_FINALIZE, _OP_ADDREF, _OP_COPY] then
+              if optoken in [_OP_INITIALIZE,_OP_FINALIZE,_OP_ADDREF,_OP_COPY,_OP_MOVE] then
                 begin
                   { single var parameter to point the record }
                   if (optoken in [_OP_INITIALIZE, _OP_FINALIZE, _OP_ADDREF]) and
@@ -1463,7 +1464,7 @@ implementation
                      ) then
                     Message(parser_e_overload_impossible)
                   { constref (source) and var (dest) parameter to point the records }
-                  else if (optoken=_OP_COPY) and
+                  else if (optoken in [_OP_COPY,_OP_MOVE]) and
                      (
                       (pd.parast.SymList.Count<>2) or
                       (tparavarsym(pd.parast.SymList[0]).vardef<>pd.struct) or
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index 5904dbeac7..1f76000f0d 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -610,7 +610,8 @@ type
     mop_initialize,
     mop_finalize,
     mop_addref,
-    mop_copy
+    mop_copy,
+    mop_move
   );
   tmanagementoperators=set of tmanagementoperator;
 
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index 305d39904a..4d4d6d82ad 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -458,6 +458,7 @@ interface
     { _OP_FINALIZE   }  'finalize',
     { _OP_ADDREF     }  'addref',
     { _OP_COPY       }  'copy',
+    { _OP_MOVE       }  'move',
     { _OP_INC        }  'inc',
     { _OP_DEC        }  'dec');
 
@@ -466,7 +467,8 @@ interface
     { mop_initialize }  _OP_INITIALIZE,
     { mop_finalize   }  _OP_FINALIZE,
     { mop_addref     }  _OP_ADDREF,
-    { mop_copy       }  _OP_COPY
+    { mop_copy       }  _OP_COPY,
+    { mop_move       }  _OP_MOVE
     );
 
 
diff --git a/compiler/tokens.pas b/compiler/tokens.pas
index e208e6bbd8..2cceab0171 100644
--- a/compiler/tokens.pas
+++ b/compiler/tokens.pas
@@ -60,6 +60,7 @@ type
     _OP_FINALIZE,
     _OP_ADDREF,
     _OP_COPY,
+    _OP_MOVE,
     _OP_INC,
     _OP_DEC,
     { special chars }
@@ -141,6 +142,7 @@ type
     _FILE,
     _GOTO,
     _HUGE,
+    _MOVE,
     _NAME,
     _NEAR,
     _READ,
@@ -337,7 +339,7 @@ const
   last_overloaded  = _OP_DEC;
   last_operator = _GENERICSPECIALTOKEN;
   first_managment_operator = _OP_INITIALIZE;
-  last_managment_operator = _OP_COPY;
+  last_managment_operator = _OP_MOVE;
 
   highest_precedence = oppower;
 
@@ -401,6 +403,7 @@ const
       (str:'finalize'      ;special:true ;keyword:[m_none];op:NOTOKEN),
       (str:'addref'        ;special:true ;keyword:[m_none];op:NOTOKEN),
       (str:'copy'          ;special:true ;keyword:[m_none];op:NOTOKEN),
+      (str:'move'          ;special:true ;keyword:[m_none];op:NOTOKEN),
       (str:'inc'           ;special:true ;keyword:[m_none];op:NOTOKEN),
       (str:'dec'           ;special:true ;keyword:[m_none];op:NOTOKEN),
     { Special chars }
@@ -482,6 +485,7 @@ const
       (str:'FILE'          ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
       (str:'GOTO'          ;special:false;keyword:alllanguagemodes;op:NOTOKEN),
       (str:'HUGE'          ;special:false;keyword:[m_none];op:NOTOKEN),
+      (str:'MOVE'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'NAME'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'NEAR'          ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'READ'          ;special:false;keyword:[m_none];op:NOTOKEN),
diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc
index 4bb4e8937b..6ec67746aa 100644
--- a/rtl/inc/compproc.inc
+++ b/rtl/inc/compproc.inc
@@ -743,7 +743,9 @@ procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); compilerp
 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;
+Function fpc_Move (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc;
 Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
+Procedure fpc_Move_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
 {$endif FPC_HAS_FEATURE_RTTI}
 
 
diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc
index 46cae4c2dd..e0da4ad8a7 100644
--- a/rtl/inc/rtti.inc
+++ b/rtl/inc/rtti.inc
@@ -104,6 +104,7 @@ begin
               rotFinalize: hasManagementOp:=Assigned(RecordOp^.Finalize);
               rotAddRef: hasManagementOp:=Assigned(RecordOp^.AddRef);
               rotCopy: hasManagementOp:=Assigned(RecordOp^.Copy);
+              rotMove: hasManagementOp:=Assigned(RecordOp^.Move);
             end;
         end;
 {$else VER3_0}
@@ -451,6 +452,136 @@ begin
   fpc_copy_internal(src,dest,typeinfo);
 end;
 
+{ define alias for internal use in the system unit }
+Function fpc_Move_internal (Src, Dest, TypeInfo : Pointer) : SizeInt;[external name 'FPC_MOVE'];
+
+Function fpc_Move (Src, Dest, TypeInfo : Pointer) : SizeInt;[Public,alias : 'FPC_MOVE']; compilerproc;
+var
+  Temp: pbyte;
+  copiedsize,
+  expectedoffset,
+  count,
+  offset,
+  i: SizeInt;
+  info: pointer;
+begin
+  result:=sizeof(pointer);
+  case PTypeKind(TypeInfo)^ of
+{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
+    tkAstring:
+      fpc_AnsiStr_Assign(PPointer(Dest)^,PPointer(Src)^);
+{$endif FPC_HAS_FEATURE_ANSISTRINGS}
+{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
+  {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+    tkWstring:
+      fpc_WideStr_Assign(PPointer(Dest)^,PPointer(Src)^);
+  {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+    tkUstring:
+      fpc_UnicodeStr_Assign(PPointer(Dest)^,PPointer(Src)^);
+{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+    tkArray:
+      begin
+{$ifdef VER3_0}
+        Temp:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
+{$else VER3_0}
+        Temp:=aligntoqword(typeInfo+2+PByte(typeInfo)[1]);
+{$endif VER3_0}
+      {$ifdef VER2_6}
+        { Process elements }
+        for I:=0 to PArrayInfo(Temp)^.ElCount-1 do
+          fpc_Copy_internal(Src+(I*PArrayInfo(Temp)^.Size),Dest+(I*PArrayInfo(Temp)^.Size),PArrayInfo(Temp)^.ElInfo);
+        Result:=PArrayInfo(Temp)^.Size*PArrayInfo(Temp)^.ElCount;
+      {$else}
+        Result:=PArrayInfo(Temp)^.Size;
+        Count:=PArrayInfo(Temp)^.ElCount;
+        { no elements to process => exit }
+        if Count = 0 then
+          Exit;
+        Info:=PArrayInfo(Temp)^.ElInfo{$ifndef VER3_0}^{$endif};
+        copiedsize:=Result div Count;
+        Offset:=0;
+        { Process elements }
+        for I:=1 to Count do
+          begin
+            fpc_Copy_internal(Src+Offset,Dest+Offset,Info);
+            inc(Offset,copiedsize);
+          end;
+      {$endif}
+      end;
+{$ifdef FPC_HAS_FEATURE_OBJECTS}
+    tkobject,
+{$endif FPC_HAS_FEATURE_OBJECTS}
+    tkrecord:
+{$ifndef VER3_0}
+      { find init table }
+      with RTTIRecordOp(typeinfo, typeinfo)^ do
+{$endif VER3_0}
+      begin
+{$ifdef VER3_0}
+        typeInfo:=RTTIRecordRttiInfoToInitInfo(typeInfo);
+        Temp:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
+{$else VER3_0}
+        Temp:=aligntoqword(typeInfo+2+PByte(typeInfo)[1]);
+{$endif VER3_0}
+{$ifndef VER3_0}
+        { during move operations the move operator takes precedence
+          over the copy operator and finally if either operator is
+          not present then standard memory move is used }
+        if Assigned(recordop) and Assigned(recordop^.Move) then
+          recordop^.Move(Src,Dest)
+        else if Assigned(recordop) and Assigned(recordop^.Copy) then
+          recordop^.Copy(Src,Dest)
+        else
+          begin
+            Result:=Size;
+            Inc(PRecordInfoInit(Temp));
+{$else VER3_0}
+            Result:=PRecordInfoFull(Temp)^.Size;
+            Count:=PRecordInfoFull(Temp)^.Count;
+            Inc(PRecordInfoFull(Temp));
+{$endif VER3_0}
+            expectedoffset:=0;
+            { Process elements with rtti }
+            for i:=1 to Count Do
+              begin
+                Info:=PRecordElement(Temp)^.TypeInfo{$ifndef VER3_0}^{$endif};
+                Offset:=PRecordElement(Temp)^.Offset;
+                Inc(PRecordElement(Temp));
+                if Offset>expectedoffset then
+                  move((Src+expectedoffset)^,(Dest+expectedoffset)^,Offset-expectedoffset);
+                copiedsize:=fpc_Move_internal(Src+Offset,Dest+Offset,Info);
+                expectedoffset:=Offset+copiedsize;
+              end;
+            { elements remaining? }
+            if result>expectedoffset then
+              move((Src+expectedoffset)^,(Dest+expectedoffset)^,Result-expectedoffset);
+{$ifndef VER3_0}
+          end;
+{$endif VER3_0}
+      end;
+{$ifdef FPC_HAS_FEATURE_DYNARRAYS}
+    tkDynArray:
+      fpc_dynarray_assign(PPointer(Dest)^,PPointer(Src)^,typeinfo);
+{$endif FPC_HAS_FEATURE_DYNARRAYS}
+    tkInterface:
+      fpc_intf_assign(PPointer(Dest)^,PPointer(Src)^);
+{$ifdef FPC_HAS_FEATURE_VARIANTS}
+    tkVariant:
+      begin
+        VarCopyProc(pvardata(dest)^,pvardata(src)^);
+        result:=sizeof(tvardata);
+      end;
+{$endif FPC_HAS_FEATURE_VARIANTS}
+  end;
+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                                               }
+procedure fpc_Move_proc (Src, Dest, TypeInfo : Pointer);compilerproc; inline;
+begin
+  fpc_move_internal(src,dest,typeinfo);
+end;
 
 procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); [public,alias:'FPC_INITIALIZE_ARRAY']; compilerproc;
   var
diff --git a/rtl/inc/rttidecl.inc b/rtl/inc/rttidecl.inc
index 55a4e6cfe6..a5135a9663 100644
--- a/rtl/inc/rttidecl.inc
+++ b/rtl/inc/rttidecl.inc
@@ -79,7 +79,8 @@ type
 {$ifndef VER3_0}
   TRTTIRecVarOp=procedure(ARec: Pointer);
   TRTTIRecCopyOp=procedure(ASrc, ADest: Pointer);
-  TRTTIRecOpType=(rotAny, rotInitialize, rotFinalize, rotAddRef, rotCopy);
+  TRTTIRecMoveOp=procedure(ASrc, ADest: Pointer);
+  TRTTIRecOpType=(rotAny, rotInitialize, rotFinalize, rotAddRef, rotCopy, rotMove);
   PRTTIRecordOpVMT=^TRTTIRecordOpVMT;
   TRTTIRecordOpVMT=
 {$ifdef USE_PACKED}
@@ -90,6 +91,7 @@ type
     Finalize: TRTTIRecVarOp;
     AddRef: TRTTIRecVarOp;
     Copy: TRTTIRecCopyOp;
+    Move: TRTTIRecMoveOp;
   end;
 
   TRTTIRecordOpOffsetEntry =
diff --git a/tests/test/tmoveop1.pp b/tests/test/tmoveop1.pp
new file mode 100644
index 0000000000..3c1560676a
--- /dev/null
+++ b/tests/test/tmoveop1.pp
@@ -0,0 +1,150 @@
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+program tmoveop1;
+
+type
+  TCopyOperations = (op_copy, op_move, op_uknown);
+var
+  LastOperation: TCopyOperations;
+
+type
+  TBase = record
+    constructor Create(val: integer);
+    class operator Copy(constref aSrc: TBase; var aDst: TBase);
+    class operator Move(constref aSrc: TBase; var aDst: TBase);
+  end;
+  PBase = ^TBase;
+  TBaseAlias = TBase;
+
+constructor TBase.Create(val: integer);
+begin
+end;
+
+class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
+begin
+  LastOperation := op_copy;
+end;
+
+class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
+begin
+  LastOperation := op_move;
+end;
+
+type
+  TMyClass = class
+    a: TBase;
+    function GetBase: TBase;
+    function GetBase_inline: TBase; inline;
+    property a0: TBase read a;
+    property a1: TBase read GetBase;
+    property a2: TBase read GetBase_inline;
+  end;
+
+function TMyClass.GetBase: TBase;
+begin
+  result := a;
+end;
+
+function TMyClass.GetBase_inline: TBase;
+begin
+  result := a;
+end;
+
+var
+  gBase: TBase;
+
+function get_pbase: PBase;
+begin
+  result := @gBase;
+end;
+
+function get_base: TBase;
+begin
+  result := gBase;
+end;
+
+procedure FailIfNot(op: TCopyOperations);
+begin
+  if LastOperation <> op then
+    begin
+      writeln('FAILED! LastOperation=', LastOperation, ' should be ', op);
+      halt(-1);
+    end;
+end;
+
+var
+  a,b: TBase;
+  p: PBase;
+  r: array of TBase;
+  c: TMyClass;
+begin
+
+  { load nodes are always copies becase they point to static memory }
+  LastOperation := op_uknown;
+  a := b;
+  FailIfNot(op_copy);
+
+  LastOperation := op_uknown;
+  a := TBaseAlias(b);
+  FailIfNot(op_copy);
+
+  { deref nodes always default to copy because we can't confirm at
+    compile time that they point to temporary memory or not }
+  LastOperation := op_uknown;
+  a := get_pbase^;
+  FailIfNot(op_copy);
+
+  LastOperation := op_uknown;
+  a := pbase(@get_base)^;
+  FailIfNot(op_copy);
+
+  { call nodes are a move operation because the function is always 
+    copy-on-pass in pascal }
+  LastOperation := op_uknown;
+  a := get_base;
+  FailIfNot(op_move);
+
+  { constructors are call nodes so same rules apply }
+  LastOperation := op_uknown;
+  a := TBase.Create(1);
+  FailIfNot(op_move);
+
+  { dynamic arrays - same rules apply as normal assignments }
+  LastOperation := op_uknown;
+  r := [a];
+  FailIfNot(op_copy);
+
+  { dynamic arrays - same rules apply as normal assignments }
+  LastOperation := op_uknown;
+  r := [TBase.Create(1)];
+  FailIfNot(op_move);
+
+  { vector nodes always default to copy because we can't confirm at
+    compile time that they point to temporary memory or not }
+  LastOperation := op_uknown;
+  a := r[0];
+  FailIfNot(op_copy);
+
+  { subscript node to field is static memory }
+  c := TMyClass.Create;
+  LastOperation := op_uknown;
+  a := c.a;
+  FailIfNot(op_copy);
+
+  { read property is fieldvarsym which is static memory }
+  LastOperation := op_uknown;
+  a := c.a0;
+  FailIfNot(op_copy);
+
+  { read property with getter function is call node and temporary }
+  LastOperation := op_uknown;
+  a := c.a1;
+  FailIfNot(op_move);
+
+  { read property with getter function is inlined so it maps
+    directly to a field and should be a copy }
+  LastOperation := op_uknown;
+  a := c.a2;
+  FailIfNot(op_copy);
+end.
diff --git a/tests/test/tmoveop2.pp b/tests/test/tmoveop2.pp
new file mode 100644
index 0000000000..9c57e06106
--- /dev/null
+++ b/tests/test/tmoveop2.pp
@@ -0,0 +1,31 @@
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+program tmoveop2;
+
+type
+  TBase = record
+    constructor Create(val: integer);
+    class operator Copy(constref aSrc: TBase; var aDst: TBase);
+  end;
+
+var
+  CopyCalled: boolean = false;
+
+constructor TBase.Create(val: integer);
+begin
+end;
+
+class operator TBase.Copy(constref aSrc: TBase; var aDst: TBase);
+begin
+  CopyCalled := true;
+end;
+
+var
+  a: TBase;
+begin
+  // the move operator is not implemented so copy operator is used
+  a := TBase.Create(1);
+  if not CopyCalled then
+    Halt(-1);
+end.
diff --git a/tests/test/tmoveop3.pp b/tests/test/tmoveop3.pp
new file mode 100644
index 0000000000..e18aa42771
--- /dev/null
+++ b/tests/test/tmoveop3.pp
@@ -0,0 +1,42 @@
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+program tmoveop3;
+
+type
+  TBase = record
+    class operator Move(constref aSrc: TBase; var aDst: TBase);
+  end;
+
+type
+  TMyRecord = record
+    field1: TBase;
+    field2: TBase;
+    constructor Create(num: integer);
+  end;
+
+var
+  MoveCalls: integer = 0;
+
+class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
+begin
+  MoveCalls += 1;
+end;
+
+constructor TMyRecord.Create(num: integer);
+begin
+end;
+
+var
+  a: TMyRecord;
+begin
+  a := TMyRecord.Create(0);
+  { TMyRecord doesn't implement Move but the 2 nested record
+    fields of type TBase do implement Move so we should get
+    2 move calls. }
+  if MoveCalls <> 2 then
+    begin
+      writeln('Failed!');
+      Halt(-1);
+    end;
+end.
\ No newline at end of file
diff --git a/tests/test/tmoveop4.pp b/tests/test/tmoveop4.pp
new file mode 100644
index 0000000000..a513466416
--- /dev/null
+++ b/tests/test/tmoveop4.pp
@@ -0,0 +1,53 @@
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+program tmoveop4;
+
+type
+  TBase = record
+    num: integer;
+    class operator Move(constref aSrc: TBase; var aDst: TBase);
+  end;
+
+type
+  TChild = record
+    base: TBase;
+  end;
+
+type
+  TMyRecord = record
+    field1: TChild;
+    field2: TChild;
+    constructor Create(num: integer);
+  end;
+
+var
+  MoveCalls: integer = 0;
+
+class operator TBase.Move(constref aSrc: TBase; var aDst: TBase);
+begin
+  MoveCalls += 1;
+  aDst.num := aSrc.num;
+end;
+
+constructor TMyRecord.Create(num: integer);
+begin
+  field1.base.num := num;
+  field2.base.num := num;
+end;
+
+const
+  kValue = 10;
+var
+  a: TMyRecord;
+begin
+  a := TMyRecord.Create(kValue);
+  { TMyRecord doesn't implement Move but the 2 nested record
+    fields of type TBase do implement Move so we should get
+    2 move calls. }
+  if (MoveCalls <> 2) or (a.field1.base.num <> kValue) or (a.field2.base.num <> kValue) then
+    begin
+      writeln('Failed!');
+      Halt(-1);
+    end;
+end.
\ No newline at end of file
-- 
2.17.2 (Apple Git-113)

patch_7_11.diff (25,437 bytes)

Issue History

Date Modified Username Field Change
2019-07-10 22:29 Ryan Joseph New Issue
2019-07-10 22:29 Ryan Joseph File Added: moveop_7_9.diff
2019-07-10 22:32 Akira1364 Note Added: 0117144
2019-07-10 22:38 Ryan Joseph Note Added: 0117145
2019-07-10 23:27 Akira1364 Note Added: 0117147
2019-07-10 23:28 Akira1364 Note Edited: 0117147 View Revisions
2019-07-11 00:15 Sven Barth Relationship added has duplicate 0035823
2019-07-11 00:31 Sven Barth Note Added: 0117150
2019-07-11 01:17 Akira1364 Note Added: 0117152
2019-07-11 01:18 Akira1364 Note Edited: 0117152 View Revisions
2019-07-11 01:21 Ryan Joseph Note Added: 0117153
2019-07-11 01:26 Ryan Joseph Note Added: 0117154
2019-07-11 01:30 Ryan Joseph Note Added: 0117155
2019-07-11 01:37 Ryan Joseph Note Added: 0117156
2019-07-11 01:40 Ryan Joseph Note Added: 0117157
2019-07-11 03:04 Ryan Joseph Note Added: 0117159
2019-07-11 16:22 Ryan Joseph File Added: patch_7_11.diff
2019-07-11 16:22 Ryan Joseph Note Added: 0117182