View Issue Details

IDProjectCategoryView StatusLast Update
0035823FPCCompilerpublic2019-07-11 00:15
ReporterRyan JosephAssigned ToSven Barth 
PrioritynormalSeverityminorReproducibilityN/A
Status resolvedResolutionduplicate 
Product Version3.3.1Product Build 
Target VersionFixed in Version 
Summary0035823: [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(val);
end;

class operator TMyRecord.Copy(constref aSrc: TMyRecord; var aDst: TMyRecord);
begin
  writeln('TMyRecord.Copy ', HexStr(@aSrc), ' to ', HexStr(@aDst));
  { ...do something... }
  aSrc.data := TData.Create;
end;

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

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

var
  a, b: TMyRecord;
begin
  { Move operator is called twice saving two copies without the move operator defined }
  a := 1;
  { Copy operator is called because "a" has static address }
  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)

Relationships

duplicate of 0035825 new [PATCH] Move management operator 

Activities

Ryan Joseph

2019-07-10 22:24

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)

Issue History

Date Modified Username Field Change
2019-07-10 22:24 Ryan Joseph New Issue
2019-07-10 22:24 Ryan Joseph File Added: moveop_7_9.diff
2019-07-11 00:15 Sven Barth Assigned To => Sven Barth
2019-07-11 00:15 Sven Barth Status new => resolved
2019-07-11 00:15 Sven Barth Resolution open => duplicate
2019-07-11 00:15 Sven Barth FPCTarget => -
2019-07-11 00:15 Sven Barth Relationship added duplicate of 0035825