* string concat changed from function to procedure to

    allow runtime optimization if the destination is the
    same as a source parameter
  * tassignmentnode now sets aktassignmentnode global that can be used
    to use the left node as a destination parameter and
    skip the assignment
  * disabled all cpu specific shortstr concat/append

git-svn-id: trunk@4770 -

compiler/nadd.pas

@@ -90,7 +90,7 @@ implementation
       symconst,symdef,symsym,symtable,defutil,defcmp,
       cgbase,
       htypechk,pass_1,
-      nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,nutils,
+      nld,nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,nutils,
       {$ifdef state_tracking}
       nstate,
       {$endif}
@@ -1579,6 +1579,8 @@ implementation
         swap_relation: array [ltn..unequaln] of Tnodetype=(gtn, gten, ltn, lten, equaln, unequaln);
       var
         p: tnode;
+        newstatement : tstatementnode;
+        tempnode : ttempcreatenode;
       begin
         { when we get here, we are sure that both the left and the right }
         { node are both strings of the same stringtype (JM)              }
@@ -1600,9 +1602,32 @@ implementation
                   exit;
                 end;
               { create the call to the concat routine both strings as arguments }
-              result := ccallnode.createintern('fpc_'+
-                tstringdef(resulttype.def).stringtypname+'_concat',
-                ccallparanode.create(right,ccallparanode.create(left,nil)));
+              if assigned(aktassignmentnode) and
+                  (aktassignmentnode.right=self) and
+                  (aktassignmentnode.left.resulttype.def=resulttype.def) and
+                  valid_for_var(aktassignmentnode.left,false) then
+                begin
+                  result:=ccallnode.createintern('fpc_'+
+                    tstringdef(resulttype.def).stringtypname+'_concat',
+                    ccallparanode.create(right,
+                    ccallparanode.create(left,
+                    ccallparanode.create(aktassignmentnode.left.getcopy,nil))));
+                  include(aktassignmentnode.flags,nf_assign_done_in_right);
+                  firstpass(result);
+                end
+              else
+                begin
+                  result:=internalstatements(newstatement);
+                  tempnode:=ctempcreatenode.create(resulttype,resulttype.def.size,tt_persistent,true);
+                  addstatement(newstatement,tempnode);
+                  addstatement(newstatement,ccallnode.createintern('fpc_'+
+                    tstringdef(resulttype.def).stringtypname+'_concat',
+                    ccallparanode.create(right,
+                    ccallparanode.create(left,
+                    ccallparanode.create(ctemprefnode.create(tempnode),nil)))));
+                  addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
+                  addstatement(newstatement,ctemprefnode.create(tempnode));
+                end;
               { we reused the arguments }
               left := nil;
               right := nil;

compiler/nbas.pas

@@ -155,6 +155,7 @@ interface
 
         { a node which removes a temp }
         ttempdeletenode = class(tnode)
+          tempinfo: ptempinfo;
           constructor create(const temp: ttempcreatenode); virtual;
           { this will convert the persistant temp to a normal temp
             for returning to the other nodes }
@@ -169,7 +170,6 @@ interface
           destructor destroy; override;
           procedure printnodedata(var t:text);override;
          protected
-          tempinfo: ptempinfo;
           release_to_normal : boolean;
         private
           tempidx : longint;

compiler/ncal.pas

@@ -140,7 +140,7 @@ interface
 
        tcallparaflag = (
           cpf_is_colon_para,
-          cpf_varargs_para   { belongs this para to varargs }
+          cpf_varargs_para       { belongs this para to varargs }
        );
        tcallparaflags = set of tcallparaflag;
 
@@ -2206,6 +2206,38 @@ type
                    )
                   ) then
                   begin
+                    tempnode:=nil;
+
+{$ifdef reuse_existing_para_temp}
+                    { Try to reuse existing result tempnode from a parameter }
+                    if para.left.nodetype=blockn then
+                      begin
+                        n:=tstatementnode(tblocknode(para.left).left);
+                        while assigned(n) and assigned(tstatementnode(n).right) do
+                          begin
+                            if tstatementnode(n).left.nodetype=tempdeleten then
+                              break;
+                            n:=tstatementnode(tstatementnode(n).right);
+                          end;
+                        { We expect to find the following statements
+                            tempdeletenode
+                            tempref
+                            nil }
+                        if assigned(n) and
+                           assigned(tstatementnode(n).right) and
+                           (tstatementnode(tstatementnode(n).right).right=nil) and
+                           (tstatementnode(tstatementnode(n).right).left.nodetype=temprefn) then
+                          begin
+                            tempnode:=ttempdeletenode(tstatementnode(n).left).tempinfo^.owner;
+                            para.left:=tstatementnode(tstatementnode(n).right).left;
+                            addstatement(deletestatement,tstatementnode(n).left);
+                            { Replace tempdelete,tempref with dummy statement }
+                            tstatementnode(n).left:=cnothingnode.create;
+                            tstatementnode(tstatementnode(n).right).left:=cnothingnode.create;
+                          end;
+                      end;
+{$endif reuse_existing_para_temp}
+
                     tempnode := ctempcreatenode.create(para.parasym.vartype,para.parasym.vartype.def.size,tt_persistent,tparavarsym(para.parasym).is_regvar(false));
                     addstatement(createstatement,tempnode);
                     { assign the value of the parameter to the temp, except in case of the function result }
@@ -2214,7 +2246,7 @@ type
                     if not(vo_is_funcret in tparavarsym(para.parasym).varoptions) then
                       begin
                         addstatement(createstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
-                          para.left));
+                            para.left));
                         para.left := ctemprefnode.create(tempnode);
                         addstatement(deletestatement,ctempdeletenode.create(tempnode));
                       end
@@ -2226,7 +2258,7 @@ type
                         para.left := ctemprefnode.create(tempnode);
 
                         addstatement(deletestatement,ctempdeletenode.create_normal_temp(tempnode));
-                      end
+                      end;
                   end
                 { otherwise if the parameter is "complex", take the address   }
                 { of the parameter expression, store it in a temp and replace }

compiler/ncgld.pas

@@ -437,37 +437,30 @@ implementation
            if codegenerror then
              exit;
 
-           if not(nf_concat_string in flags) then
-            begin
-              { left can't be never a 64 bit LOC_REGISTER, so the 3. arg }
-              { can be false                                             }
-              secondpass(left);
-              { decrement destination reference counter }
-              if (left.resulttype.def.needs_inittable) then
-                begin
-                  location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false);
-                  cg.g_decrrefcount(current_asmdata.CurrAsmList,left.resulttype.def,href);
-                end;
-              if codegenerror then
-                exit;
-            end;
+           { left can't be never a 64 bit LOC_REGISTER, so the 3. arg }
+           { can be false                                             }
+           secondpass(left);
+           { decrement destination reference counter }
+           if (left.resulttype.def.needs_inittable) then
+             begin
+               location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false);
+               cg.g_decrrefcount(current_asmdata.CurrAsmList,left.resulttype.def,href);
+             end;
+           if codegenerror then
+             exit;
          end
         else
          begin
            { calculate left sides }
-           { don't do it yet if it's a crgister (JM) }
-           if not(nf_concat_string in flags) then
+           secondpass(left);
+           { decrement destination reference counter }
+           if (left.resulttype.def.needs_inittable) then
              begin
-               secondpass(left);
-               { decrement destination reference counter }
-               if (left.resulttype.def.needs_inittable) then
-                 begin
-                   location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false);
-                   cg.g_decrrefcount(current_asmdata.CurrAsmList,left.resulttype.def,href);
-                 end;
-               if codegenerror then
-                 exit;
+               location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false);
+               cg.g_decrrefcount(current_asmdata.CurrAsmList,left.resulttype.def,href);
              end;
+           if codegenerror then
+             exit;
 
            { left can't be never a 64 bit LOC_REGISTER, so the 3. arg }
            { can be false                                             }
@@ -489,7 +482,8 @@ implementation
         releaseright:=true;
 
         { optimize temp to temp copies }
-(*        if (left.nodetype = temprefn) and
+{$ifdef old_append_str}
+        if (left.nodetype = temprefn) and
            { we may store certain temps in registers in the future, then this }
            { optimization will have to be adapted                             }
            (left.location.loc = LOC_REFERENCE) and
@@ -504,7 +498,9 @@ implementation
             tcgtemprefnode(left).changelocation(right.location.reference);
           end
         { shortstring assignments are handled separately }
-        else *)
+        else
+{$endif old_append_str}
+
         if is_shortstring(left.resulttype.def) then
           begin
             {
@@ -514,8 +510,13 @@ implementation
                - char
             }
 
+            { The addn is replaced by a blockn or calln }
+            if right.nodetype in [blockn,calln] then
+              begin
+                { nothing to do }
+              end
             { empty constant string }
-            if (right.nodetype=stringconstn) and
+            else if (right.nodetype=stringconstn) and
                (tstringconstnode(right).len=0) then
               begin
                 cg.a_load_const_ref(current_asmdata.CurrAsmList,OS_8,0,left.location.reference);

compiler/ncgopt.pas

@@ -93,8 +93,7 @@ begin
   { ti386addnode.pass_2                                     }
   secondpass(left);
   if not(tg.istemp(left.location.reference) and
-         (tg.sizeoftemp(current_asmdata.CurrAsmList,left.location.reference) = 256)) and
-     not(nf_use_strconcat in flags) then
+         (tg.sizeoftemp(current_asmdata.CurrAsmList,left.location.reference) = 256)) then
     begin
        tg.Gettemp(current_asmdata.CurrAsmList,256,tt_normal,href);
        cg.g_copyshortstring(current_asmdata.CurrAsmList,left.location.reference,href,255);

compiler/nld.pas

@@ -131,6 +131,8 @@ interface
        ctypenode : ttypenodeclass;
        crttinode : trttinodeclass;
 
+       { Current assignment node }
+       aktassignmentnode : tassignmentnode;
 
 
 implementation
@@ -140,7 +142,7 @@ implementation
       symnot,
       defutil,defcmp,
       htypechk,pass_1,procinfo,paramgr,
-      ncon,ninl,ncnv,nmem,ncal,nutils,
+      ncon,ninl,ncnv,nmem,ncal,nutils,nbas,
       cgobj,cgbase
       ;
 
@@ -491,6 +493,7 @@ implementation
 
         resulttypepass(left);
 
+{$ifdef old_append_str}
         if is_ansistring(left.resulttype.def) then
           begin
             { fold <ansistring>:=<ansistring>+<char|shortstring|ansistring> }
@@ -530,6 +533,7 @@ implementation
               end;
           end
         else
+
          if is_shortstring(left.resulttype.def) then
           begin
             { fold <shortstring>:=<shortstring>+<shortstring>,
@@ -561,6 +565,7 @@ implementation
                  end;
               end;
           end;
+{$endif old_append_str}
 
         resulttypepass(right);
         set_varstate(right,vs_read,[vsf_must_be_valid]);
@@ -698,20 +703,65 @@ implementation
     function tassignmentnode.pass_1 : tnode;
       var
         hp: tnode;
+        oldassignmentnode : tassignmentnode;
       begin
          result:=nil;
          expectloc:=LOC_VOID;
 
          firstpass(left);
+
+         { Optimize the reuse of the destination of the assingment in left.
+           Allow the use of the left inside the tree generated on the right.
+           This is especially usefull for string routines where the destination
+           is pushed as a parameter. Using the final destination of left directly
+           save a temp allocation and copy of data (PFV) }
+         oldassignmentnode:=aktassignmentnode;
+         if right.nodetype=addn then
+           aktassignmentnode:=self
+         else
+           aktassignmentnode:=nil;
          firstpass(right);
+         aktassignmentnode:=oldassignmentnode;
+         if nf_assign_done_in_right in flags then
+           begin
+             result:=right;
+             right:=nil;
+             exit;
+           end;
+
+         if codegenerror then
+           exit;
+
+         if (cs_opt_level1 in aktoptimizerswitches) and
+            (right.nodetype = calln) and
+            (right.resulttype.def=left.resulttype.def) and
+            { left must be a temp, since otherwise as soon as you modify the }
+            { result, the current left node is modified and that one may     }
+            { still be an argument to the function or even accessed in the   }
+            { function                                                       }
+            (
+             (
+              (left.nodetype = temprefn) and
+              paramanager.ret_in_param(right.resulttype.def,tcallnode(right).procdefinition.proccalloption)
+             ) or
+             { there's special support for ansi/widestrings in the callnode }
+             is_ansistring(right.resulttype.def) or
+             is_widestring(right.resulttype.def)
+            )  then
+           begin
+             make_not_regable(left,vr_addr);
+             tcallnode(right).funcretnode := left;
+             result := right;
+             left := nil;
+             right := nil;
+             exit;
+           end;
+
          { assignment to refcounted variable -> inc/decref }
          if (not is_class(left.resulttype.def) and
             left.resulttype.def.needs_inittable) then
            include(current_procinfo.flags,pi_do_call);
 
-         if codegenerror then
-           exit;
-
 
         if (is_shortstring(left.resulttype.def)) then
           begin
@@ -720,6 +770,7 @@ implementation
               if (right.nodetype<>stringconstn) or
                  (tstringconstnode(right).len<>0) then
                begin
+{$ifdef old_append_str}
                  if (cs_opt_level1 in aktoptimizerswitches) and
                     (right.nodetype in [calln,blockn]) and
                     (left.nodetype = temprefn) and
@@ -738,6 +789,7 @@ implementation
                        exit;
                    end
                  else
+{$endif old_append_str}
                    begin
                      hp:=ccallparanode.create
                            (right,
@@ -753,27 +805,6 @@ implementation
             end;
            end;
 
-         if (cs_opt_level1 in aktoptimizerswitches) and
-            (right.nodetype = calln) and
-            { left must be a temp, since otherwise as soon as you modify the }
-            { result, the current left node is modified and that one may     }
-            { still be an argument to the function or even accessed in the   }
-            { function                                                       }
-            (((left.nodetype = temprefn) and
-              paramanager.ret_in_param(right.resulttype.def,
-                tcallnode(right).procdefinition.proccalloption)) or
-             { there's special support for ansi/widestrings in the callnode }
-             is_ansistring(right.resulttype.def) or
-             is_widestring(right.resulttype.def))  then
-           begin
-             make_not_regable(left,vr_addr);
-             tcallnode(right).funcretnode := left;
-             result := right;
-             left := nil;
-             right := nil;
-             exit;
-           end;
-
          registersint:=left.registersint+right.registersint;
          registersfpu:=max(left.registersfpu,right.registersfpu);
 {$ifdef SUPPORT_MMX}
@@ -872,8 +903,11 @@ implementation
       begin
         result:=nil;
 
-      { are we allowing array constructor? Then convert it to a set }
-        if not allow_array_constructor then
+      { are we allowing array constructor? Then convert it to a set.
+        Do this only if we didn't convert the arrayconstructor yet. This
+        is needed for the cases where the resulttype is forced for a second
+        run }
+        if (not allow_array_constructor) then
          begin
            hp:=tarrayconstructornode(getcopy);
            arrayconstructor_to_set(tnode(hp));

compiler/nmem.pas

@@ -342,8 +342,13 @@ implementation
 
         make_not_regable(left,vr_addr);
 
-        { don't allow constants }
-        if is_constnode(left) then
+        { don't allow constants, for internal use we also
+          allow taking the address of strings }
+        if is_constnode(left) and
+           not(
+               (nf_internal in flags) and
+               (left.nodetype in [stringconstn])
+              ) then
          begin
            aktfilepos:=left.fileinfo;
            CGMessage(type_e_no_addr_of_constant);

compiler/node.pas

@@ -223,8 +223,7 @@ interface
          nf_short_bool,
 
          { tassignmentnode }
-         nf_concat_string,
-         nf_use_strconcat,
+         nf_assign_done_in_right,
 
          { tarrayconstructnode }
          nf_forcevaria,

compiler/nopt.pas

@@ -25,7 +25,7 @@ unit nopt;
 
 interface
 
-uses node, nadd;
+uses node,nbas,nadd;
 
 type
   tsubnodetype = (
@@ -86,7 +86,7 @@ var
 
 implementation
 
-uses cutils, htypechk, defutil, defcmp, globtype, globals, cpubase, ncnv, ncon,ncal,nld,
+uses cutils, htypechk, defutil, defcmp, globtype, globals, cpubase, ncnv, ncon,ncal,nld,nmem,
      verbose, symconst,symdef, cgbase, procinfo;
 
 
@@ -289,16 +289,15 @@ var
   hp : tnode;
   i  : longint;
 begin
+  result:=false;
+  if p.resulttype.def.deftype<>stringdef then
+    exit;
   i:=0;
-  if is_ansistring(p.resulttype.def) or
-     is_widestring(p.resulttype.def) then
+  hp:=p;
+  while assigned(hp) and (hp.nodetype=addn) do
     begin
-      hp:=p;
-      while assigned(hp) and (hp.nodetype=addn) do
-        begin
-          inc(i);
-          hp:=taddnode(hp).left;
-        end;
+      inc(i);
+      hp:=taddnode(hp).left;
     end;
   result:=(i>1);
 end;
@@ -306,20 +305,58 @@ end;
 
 function genmultistringadd(p: taddnode): tnode;
 var
-  hp : tnode;
+  hp,sn : tnode;
   arrp  : tarrayconstructornode;
+  newstatement : tstatementnode;
+  tempnode    : ttempcreatenode;
+  is_shortstr : boolean;
 begin
   arrp:=nil;
   hp:=p;
+  is_shortstr:=is_shortstring(p.resulttype.def);
   while assigned(hp) and (hp.nodetype=addn) do
     begin
-      arrp:=carrayconstructornode.create(taddnode(hp).right.getcopy,arrp);
+      sn:=taddnode(hp).right.getcopy;
+      inserttypeconv(sn,p.resulttype);
+      if is_shortstr then
+        begin
+          sn:=caddrnode.create(sn);
+          include(sn.flags,nf_internal);
+        end;
+      arrp:=carrayconstructornode.create(sn,arrp);
       hp:=taddnode(hp).left;
     end;
-  arrp:=carrayconstructornode.create(hp.getcopy,arrp);
-  result := ccallnode.createintern('fpc_'+
-    tstringdef(p.resulttype.def).stringtypname+'_concat_multi',
-    ccallparanode.create(arrp,nil));
+  sn:=hp.getcopy;
+  inserttypeconv(sn,p.resulttype);
+  if is_shortstr then
+    begin
+      sn:=caddrnode.create(sn);
+      include(sn.flags,nf_internal);
+    end;
+  arrp:=carrayconstructornode.create(sn,arrp);
+  if assigned(aktassignmentnode) and
+     (aktassignmentnode.right=p) and
+     (aktassignmentnode.left.resulttype.def=p.resulttype.def) and
+     valid_for_var(aktassignmentnode.left,false) then
+    begin
+      result:=ccallnode.createintern('fpc_'+
+        tstringdef(p.resulttype.def).stringtypname+'_concat_multi',
+        ccallparanode.create(arrp,
+        ccallparanode.create(aktassignmentnode.left.getcopy,nil)));
+      include(aktassignmentnode.flags,nf_assign_done_in_right);
+    end
+  else
+    begin
+      result:=internalstatements(newstatement);
+      tempnode:=ctempcreatenode.create(p.resulttype,p.resulttype.def.size,tt_persistent ,true);
+      addstatement(newstatement,tempnode);
+      addstatement(newstatement,ccallnode.createintern('fpc_'+
+        tstringdef(p.resulttype.def).stringtypname+'_concat_multi',
+        ccallparanode.create(arrp,
+        ccallparanode.create(ctemprefnode.create(tempnode),nil))));
+      addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
+      addstatement(newstatement,ctemprefnode.create(tempnode));
+    end;
 end;
 
 

compiler/nutils.pas

@@ -634,7 +634,7 @@ implementation
       begin
         result:=fen_false;
 
-        do_resulttypepass(n);
+//        do_resulttypepass(n);
 
         hn:=n.simplify;
         if assigned(hn) then

compiler/options.pas

@@ -1920,7 +1920,7 @@ begin
 {$ifdef x86}
 {  def_system_macro('INTERNAL_BACKTRACE');}
 {$endif}
-
+  def_system_macro('STR_CONCAT_PROCS');
   if pocall_default = pocall_register then
     def_system_macro('REGCALL');
 

rtl/i386/i386.inc

@@ -769,6 +769,8 @@ end;
 {$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN}
 
 
+{$ifndef STR_CONCAT_PROCS}
+
 {$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
 {$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
 
@@ -873,6 +875,7 @@ begin
 end;
 {$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR}
 
+{$endif STR_CONCAT_PROCS}
 
 {$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
 {$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}

rtl/inc/astrings.inc

@@ -125,23 +125,27 @@ end;
 { also define alias which can be used inside the system unit }
 Procedure fpc_AnsiStr_Incr_Ref (S : Pointer); [external name 'FPC_ANSISTR_INCR_REF'];
 
-Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_ANSISTR_ASSIGN'];  compilerproc;
+Procedure fpc_AnsiStr_Assign (Var DestS : Pointer;S2 : Pointer);[Public,Alias:'FPC_ANSISTR_ASSIGN'];  compilerproc;
 {
   Assigns S2 to S1 (S1:=S2), taking in account reference counts.
 }
 begin
+  if DestS=S2 then
+    exit;
   If S2<>nil then
     If PAnsiRec(S2-FirstOff)^.Ref>0 then
       inclocked(PAnsiRec(S2-FirstOff)^.ref);
   { Decrease the reference count on the old S1 }
-  fpc_ansistr_decr_ref (S1);
-  { And finally, have S1 pointing to S2 (or its copy) }
-  S1:=S2;
+  fpc_ansistr_decr_ref (DestS);
+  { And finally, have DestS pointing to S2 (or its copy) }
+  DestS:=S2;
 end;
 
 { alias for internal use }
 Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_ANSISTR_ASSIGN'];
 
+{$ifndef STR_CONCAT_PROCS}
+
 function fpc_AnsiStr_Concat (const S1,S2 : AnsiString): ansistring; compilerproc;
 Var
   Size,Location : SizeInt;
@@ -173,14 +177,14 @@ Var
   i  : Longint;
   p  : pointer;
   pc : pchar;
-  Size,NewSize : SizeInt;
+  Size,NewLen : SizeInt;
 begin
   { First calculate size of the result so we can do
     a single call to SetLength() }
-  NewSize:=0;
+  NewLen:=0;
   for i:=low(sarr) to high(sarr) do
-    inc(Newsize,length(sarr[i]));
-  SetLength(result,NewSize);
+    inc(NewLen,length(sarr[i]));
+  SetLength(result,NewLen);
   pc:=pchar(result);
   for i:=low(sarr) to high(sarr) do
     begin
@@ -194,6 +198,104 @@ begin
     end;
 end;
 
+{$else STR_CONCAT_PROCS}
+
+procedure fpc_AnsiStr_Concat (var DestS:ansistring;const S1,S2 : AnsiString); compilerproc;
+Var
+  Size,Location : SizeInt;
+begin
+  { only assign if s1 or s2 is empty }
+  if (S1='') then
+    begin
+      DestS:=s2;
+      exit;
+    end;
+  if (S2='') then
+    begin
+      DestS:=s1;
+      exit;
+    end;
+  Location:=Length(S1);
+  Size:=length(S2);
+  { Use Pointer() typecasts to prevent extra conversion code }
+  if Pointer(DestS)=Pointer(S1) then
+    begin
+      SetLength(DestS,Size+Location);
+      Move(Pointer(S2)^,(Pointer(DestS)+Location)^,Size+1);
+    end
+  else if Pointer(DestS)=Pointer(S2) then
+    begin
+      SetLength(DestS,Size+Location);
+      Move(Pointer(DestS)^,(Pointer(DestS)+Location)^,Size+1);
+      Move(Pointer(S1)^,Pointer(DestS)^,Location);
+    end
+  else
+    begin
+      DestS:='';
+      SetLength(DestS,Size+Location);
+      Move(Pointer(S1)^,Pointer(DestS)^,Location);
+      Move(Pointer(S2)^,(Pointer(DestS)+Location)^,Size+1);
+    end;
+end;
+
+
+procedure fpc_AnsiStr_Concat_multi (var DestS:ansistring;const sarr:array of Ansistring); compilerproc;
+Var
+  lowstart,i  : Longint;
+  p,pc        : pointer;
+  Size,NewLen,
+  OldDestLen  : SizeInt;
+begin
+  if high(sarr)=0 then
+    begin
+      DestS:='';
+      exit;
+    end;
+  lowstart:=low(sarr);
+  if Pointer(DestS)=Pointer(sarr[lowstart]) then
+    begin
+      inc(lowstart);
+      { Check for another reuse, then we can't use
+        the append optimization }
+      for i:=lowstart to high(sarr) do
+        begin
+          if Pointer(DestS)=Pointer(sarr[i]) then
+            begin
+              lowstart:=low(sarr);
+              break;
+            end;
+        end;
+    end;
+  { Start with empty DestS if we start with concatting
+    the first array element }
+  if lowstart=low(sarr) then
+    DestS:='';
+  OldDestLen:=length(DestS);
+  { Calculate size of the result so we can do
+    a single call to SetLength() }
+  NewLen:=0;
+  for i:=low(sarr) to high(sarr) do
+    inc(NewLen,length(sarr[i]));
+  SetLength(DestS,NewLen);
+  { Concat all strings, except the string we already
+    copied in DestS }
+  pc:=Pointer(DestS)+OldDestLen;
+  for i:=lowstart to high(sarr) do
+    begin
+      p:=pointer(sarr[i]);
+      if assigned(p) then
+        begin
+          Size:=length(ansistring(p));
+          Move(p^,pc^,Size+1);
+          inc(pc,size);
+        end;
+    end;
+end;
+
+
+{$endif STR_CONCAT_PROCS}
+
+
 
 {$ifdef EXTRAANSISHORT}
 Procedure AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString);
@@ -806,9 +908,7 @@ Procedure SetString (Out S : AnsiString; Buf : PChar; Len : SizeInt); {$IFNDEF V
 begin
   SetLength(S,Len);
   If (Buf<>Nil) then
-    begin
-      Move (Buf[0],S[1],Len);
-    end;
+    Move (Buf^,Pointer(S)^,Len);
 end;
 
 

rtl/inc/compproc.inc

@@ -37,7 +37,12 @@ Procedure fpc_freemem(p:pointer);compilerproc;
 
 procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt); compilerproc;
 function fpc_shortstr_to_shortstr(len:longint; const sstr: shortstring): shortstring; compilerproc;
+{$ifndef STR_CONCAT_PROCS}
 function fpc_shortstr_concat(const s1,s2:shortstring): shortstring; compilerproc;
+{$else STR_CONCAT_PROCS}
+procedure fpc_shortstr_concat(var dests:shortstring;const s1,s2:shortstring);compilerproc;
+procedure fpc_shortstr_concat_multi(var dests:shortstring;const sarr:array of pshortstring);compilerproc;
+{$endif STR_CONCAT_PROCS}
 procedure fpc_shortstr_append_shortstr(var s1:shortstring;const s2:shortstring); compilerproc;
 function fpc_shortstr_compare(const left,right:shortstring) : longint; compilerproc;
 
@@ -107,9 +112,14 @@ Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64
 
 Procedure fpc_ansistr_decr_ref (Var S : Pointer); compilerproc;
 Procedure fpc_ansistr_incr_ref (S : Pointer); compilerproc;
-Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer); compilerproc;
+Procedure fpc_AnsiStr_Assign (Var DestS : Pointer;S2 : Pointer); compilerproc;
+{$ifdef STR_CONCAT_PROCS}
+Procedure fpc_AnsiStr_Concat (Var DestS : Ansistring;const S1,S2 : AnsiString); compilerproc;
+Procedure fpc_AnsiStr_Concat_multi (Var DestS : Ansistring;const sarr:array of Ansistring); compilerproc;
+{$else STR_CONCAT_PROCS}
 function fpc_AnsiStr_Concat (const S1,S2 : AnsiString): AnsiString; compilerproc;
 function fpc_AnsiStr_Concat_multi (const sarr:array of Ansistring): ansistring; compilerproc;
+{$endif STR_CONCAT_PROCS}
 Procedure fpc_ansistr_append_char(Var S : AnsiString;c : char); compilerproc;
 Procedure fpc_ansistr_append_shortstring(Var S : AnsiString;const Str : ShortString); compilerproc;
 Procedure fpc_ansistr_append_ansistring(Var S : AnsiString;const Str : AnsiString); compilerproc;
@@ -141,8 +151,13 @@ Function fpc_ShortStr_To_WideStr (Const S2 : ShortString): WideString; compilerp
 Function fpc_WideStr_To_AnsiStr (const S2 : WideString): AnsiString; compilerproc;
 Function fpc_AnsiStr_To_WideStr (Const S2 : AnsiString): WideString; compilerproc;
 Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer); compilerproc;
+{$ifndef STR_CONCAT_PROCS}
 Function fpc_WideStr_Concat (const S1,S2 : WideString) : WideString; compilerproc;
 function fpc_WideStr_Concat_multi (const sarr:array of Widestring): widestring; compilerproc;
+{$else STR_CONCAT_PROCS}
+Procedure fpc_WideStr_Concat (Var DestS : Widestring;const S1,S2 : WideString); compilerproc;
+Procedure fpc_WideStr_Concat_multi (Var DestS : Widestring;const sarr:array of Widestring); compilerproc;
+{$endif STR_CONCAT_PROCS}
 Function fpc_Char_To_WideStr(const c : WideChar): WideString; compilerproc;
 Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
 Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;

rtl/inc/generic.inc

@@ -535,6 +535,8 @@ end;
 
 {$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
 
+{$ifndef STR_CONCAT_PROCS}
+
 function fpc_shortstr_concat(const s1,s2:shortstring): shortstring;[public,alias:'FPC_SHORTSTR_CONCAT']; compilerproc;
 var
   s1l, s2l : byte;
@@ -547,6 +549,100 @@ begin
   move(s2[1],fpc_shortstr_concat[s1l+1],s2l);
   fpc_shortstr_concat[0]:=chr(s1l+s2l);
 end;
+
+{$else STR_CONCAT_PROCS}
+
+procedure fpc_shortstr_concat(var dests:shortstring;const s1,s2:shortstring);compilerproc;
+var
+  s1l, s2l : byte;
+begin
+  s1l:=length(s1);
+  s2l:=length(s2);
+  if s1l+s2l>high(dests) then
+    s2l:=high(dests)-s1l;
+  if @dests=@s1 then
+    move(s2[1],dests[s1l+1],s2l)
+  else
+    if @dests=@s2 then
+      begin
+        move(dests[1],dests[s1l+1],s2l);
+        move(s1[1],dests[1],s1l);
+      end
+  else
+    begin
+      move(s1[1],dests[1],s1l);
+      move(s2[1],dests[s1l+1],s2l);
+    end;
+  dests[0]:=chr(s1l+s2l);
+end;
+
+procedure fpc_shortstr_concat_multi(var dests:shortstring;const sarr:array of pshortstring);compilerproc;
+var
+  s2l : byte;
+  LowStart,i,
+  Len : longint;
+  pc : pchar;
+  needtemp : boolean;
+  tmpstr  : shortstring;
+  p,pdest  : pshortstring;
+begin
+  if high(sarr)=0 then
+    begin
+      DestS:='';
+      exit;
+    end;
+  lowstart:=low(sarr);
+  if Pointer(@DestS)=Pointer(sarr[lowstart]) then
+    inc(lowstart);
+  { Check for another reuse, then we can't use
+    the append optimization and need to use a temp }
+  needtemp:=false;
+  for i:=lowstart to high(sarr) do
+    begin
+      if Pointer(@DestS)=Pointer(sarr[i]) then
+        begin
+          needtemp:=true;
+          break;
+        end;
+    end;
+  if needtemp then
+    begin
+      lowstart:=low(sarr);
+      tmpstr:='';
+      pdest:=@tmpstr
+    end
+  else
+    begin
+      { Start with empty DestS if we start with concatting
+        the first array element }
+      if lowstart=low(sarr) then
+        DestS:='';
+      pdest:=@DestS;
+    end;
+  { Concat all strings, except the string we already
+    copied in DestS }
+  Len:=length(pdest^);
+  pc:=@pdest^[1+Length(pdest^)];
+  for i:=lowstart to high(sarr) do
+    begin
+      p:=sarr[i];
+      if assigned(p) then
+        begin
+          s2l:=length(p^);
+          if Len+s2l>high(dests) then
+            s2l:=high(dests)-Len;
+          Move(p^[1],pc^,s2l);
+          inc(pc,s2l);
+          inc(Len,s2l);
+        end;
+    end;
+  pdest^[0]:=Chr(Len);
+  if needtemp then
+    DestS:=TmpStr;
+end;
+
+{$endif STR_CONCAT_PROCS}
+
 {$endif ndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
 
 

rtl/inc/wstrings.inc

@@ -386,6 +386,8 @@ end;
 { alias for internal use }
 Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
 
+{$ifndef STR_CONCAT_PROCS}
+
 function fpc_WideStr_Concat (const S1,S2 : WideString): WideString; compilerproc;
 Var
   Size,Location : SizeInt;
@@ -438,6 +440,103 @@ begin
     end;
 end;
 
+{$else STR_CONCAT_PROCS}
+
+procedure fpc_WideStr_Concat (var DestS:Widestring;const S1,S2 : WideString); compilerproc;
+Var
+  Size,Location : SizeInt;
+  pc : pwidechar;
+begin
+  { only assign if s1 or s2 is empty }
+  if (S1='') then
+    begin
+      DestS:=s2;
+      exit;
+    end;
+  if (S2='') then
+    begin
+      DestS:=s1;
+      exit;
+    end;
+  Location:=Length(S1);
+  Size:=length(S2);
+  { Use Pointer() typecasts to prevent extra conversion code }
+  if Pointer(DestS)=Pointer(S1) then
+    begin
+      SetLength(DestS,Size+Location);
+      Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+    end
+  else if Pointer(DestS)=Pointer(S2) then
+    begin
+      SetLength(DestS,Size+Location);
+      Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+      Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
+    end
+  else
+    begin
+      DestS:='';
+      SetLength(DestS,Size+Location);
+      Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
+      Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+    end;
+end;
+
+
+procedure fpc_WideStr_Concat_multi (var DestS:Widestring;const sarr:array of Widestring); compilerproc;
+Var
+  lowstart,i  : Longint;
+  p,pc        : pointer;
+  Size,NewLen,
+  OldDestLen  : SizeInt;
+begin
+  if high(sarr)=0 then
+    begin
+      DestS:='';
+      exit;
+    end;
+  lowstart:=low(sarr);
+  if Pointer(DestS)=Pointer(sarr[lowstart]) then
+    begin
+      inc(lowstart);
+      { Check for another reuse, then we can't use
+        the append optimization }
+      for i:=lowstart to high(sarr) do
+        begin
+          if Pointer(DestS)=Pointer(sarr[i]) then
+            begin
+              lowstart:=low(sarr);
+              break;
+            end;
+        end;
+    end;
+  { Start with empty DestS if we start with concatting
+    the first array element }
+  if lowstart=low(sarr) then
+    DestS:='';
+  OldDestLen:=length(DestS);
+  { Calculate size of the result so we can do
+    a single call to SetLength() }
+  NewLen:=0;
+  for i:=low(sarr) to high(sarr) do
+    inc(NewLen,length(sarr[i]));
+  SetLength(DestS,NewLen);
+  { Concat all strings, except the string we already
+    copied in DestS }
+  pc:=Pointer(DestS)+OldDestLen*sizeof(WideChar);
+  for i:=lowstart to high(sarr) do
+    begin
+      p:=pointer(sarr[i]);
+      if assigned(p) then
+        begin
+          Size:=length(widestring(p));
+          Move(p^,pc^,(Size+1)*sizeof(WideChar));
+          inc(pc,size*sizeof(WideChar));
+        end;
+    end;
+end;
+
+{$endif STR_CONCAT_PROCS}
+
 
 Function fpc_Char_To_WideStr(const c : WideChar): WideString; compilerproc;
 {

rtl/powerpc/powerpc.inc

@@ -868,6 +868,8 @@ asm
 end;
 {$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN}
 
+{$ifndef STR_CONCAT_PROCS}
+
 (*
 {$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
 {$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
@@ -959,6 +961,8 @@ asm
 end;
 {$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR}
 
+{$endif STR_CONCAT_PROCS}
+
 (*
 {$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
 function fpc_shortstr_compare(const dstr,sstr:shortstring): longint; [public,alias:'FPC_SHORTSTR_COMPARE']; compilerproc;

rtl/powerpc64/powerpc64.inc

@@ -54,7 +54,7 @@ end;
 {$define FPC_SYSTEM_HAS_MOVE}
 procedure Move(const source;var dest;count:SizeInt);[public, alias: 'FPC_MOVE'];
 type
-  bytearray    = array [0..high(sizeint)-1] of byte;
+  bytearray    = array [0..high(sizeint)-1] of byte;
 var
   i:longint;
 begin
@@ -66,7 +66,7 @@ begin
         bytearray(dest)[i]:=bytearray(source)[i];
     end
   else
-    begin
+    begin
       for i:=0 to count do
         bytearray(dest)[i]:=bytearray(source)[i];
     end;
@@ -377,6 +377,8 @@ asm
 end;
 {$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN}
 
+{$ifndef STR_CONCAT_PROCS}
+
 (*
 {$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
 {$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
@@ -469,6 +471,8 @@ asm
 end;
 {$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR}
 
+{$endif STR_CONCAT_PROCS}
+
 (*
 {$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
 function fpc_shortstr_compare(const dstr, sstr:shortstring): SizeInt; [public,alias:'FPC_SHORTSTR_COMPARE']; compilerproc;
@@ -742,93 +746,93 @@ asm
         bne     .LInterLockedXchgAddLoop
         sub     r3,r10,r4
 end;
-
-function InterlockedCompareExchange(var Target: longint; NewValue: longint; Comperand: longint): longint; assembler; nostackframe;
-{ input:  address of target in r3, newvalue in r4, comparand in r5 }
-{ output: value stored in target before entry of the function      }
-{ side-effect: NewValue stored in target if (target = comparand)   }
-asm
-.LInterlockedCompareExchangeLoop:
-  lwarx  r10,0,r3
-  sub    r9,r10,r5
-  addic  r9,r9,-1
-  subfe  r9,r9,r9
-  and    r8,r4,r9
-  andc   r7,r5,r9
-  or     r6,r7,r8
-  stwcx. r6,0,r3
-  bne .LInterlockedCompareExchangeLoop
-  mr     r3, r6
-end;
-
-function InterLockedDecrement64(var Target: Int64) : Int64; assembler; nostackframe;
-{ input:  address of target in r3 }
-{ output: target-1 in r3          }
-{ side-effect: target := target-1 }
-asm
-.LInterLockedDecLoop:
-        ldarx   r10,0,r3
-        subi    r10,r10,1
-        stdcx.  r10,0,r3
-        bne     .LInterLockedDecLoop
-        mr      r3,r10
-end;
-
-
-function InterLockedIncrement64(var Target: Int64) : Int64; assembler; nostackframe;
-{ input:  address of target in r3 }
-{ output: target+1 in r3          }
-{ side-effect: target := target+1 }
-asm
-.LInterLockedIncLoop:
-        ldarx   r10,0,r3
-        addi    r10,r10,1
-        stdcx.  r10,0,r3
-        bne     .LInterLockedIncLoop
-        mr      r3,r10
-end;
-
-
-function InterLockedExchange64(var Target: Int64; Source : Int64) : Int64; assembler; nostackframe;
-{ input:  address of target in r3, source in r4 }
-{ output: target in r3                          }
-{ side-effect: target := source                 }
-asm
-.LInterLockedXchgLoop:
-        ldarx   r10,0,r3
-        stdcx.  r4,0,r3
-        bne     .LInterLockedXchgLoop
-        mr      r3,r10
-end;
-
-
-function InterLockedExchangeAdd64(var Target: Int64; Source : Int64) : Int64; assembler; nostackframe;
-{ input:  address of target in r3, source in r4 }
-{ output: target in r3                          }
-{ side-effect: target := target+source          }
-asm
-.LInterLockedXchgAddLoop:
-        ldarx   r10,0,r3
-        add     r10,r10,r4
-        stdcx.  r10,0,r3
-        bne     .LInterLockedXchgAddLoop
-        sub     r3,r10,r4
-end;
-
-function InterlockedCompareExchange64(var Target: Int64; NewValue: Int64; Comperand: Int64): Int64; assembler; nostackframe;
-{ input:  address of target in r3, newvalue in r4, comparand in r5 }
-{ output: value stored in target before entry of the function      }
-{ side-effect: NewValue stored in target if (target = comparand)   }
-asm
-.LInterlockedCompareExchangeLoop:
-  ldarx  r10,0,r3
-  sub    r9,r10,r5
-  addic  r9,r9,-1
-  subfe  r9,r9,r9
-  and    r8,r4,r9
-  andc   r7,r5,r9
-  or     r6,r7,r8
-  stdcx. r6,0,r3
-  bne .LInterlockedCompareExchangeLoop
-  mr     r3, r6
-end;
+
+function InterlockedCompareExchange(var Target: longint; NewValue: longint; Comperand: longint): longint; assembler; nostackframe;
+{ input:  address of target in r3, newvalue in r4, comparand in r5 }
+{ output: value stored in target before entry of the function      }
+{ side-effect: NewValue stored in target if (target = comparand)   }
+asm
+.LInterlockedCompareExchangeLoop:
+  lwarx  r10,0,r3
+  sub    r9,r10,r5
+  addic  r9,r9,-1
+  subfe  r9,r9,r9
+  and    r8,r4,r9
+  andc   r7,r5,r9
+  or     r6,r7,r8
+  stwcx. r6,0,r3
+  bne .LInterlockedCompareExchangeLoop
+  mr     r3, r6
+end;
+
+function InterLockedDecrement64(var Target: Int64) : Int64; assembler; nostackframe;
+{ input:  address of target in r3 }
+{ output: target-1 in r3          }
+{ side-effect: target := target-1 }
+asm
+.LInterLockedDecLoop:
+        ldarx   r10,0,r3
+        subi    r10,r10,1
+        stdcx.  r10,0,r3
+        bne     .LInterLockedDecLoop
+        mr      r3,r10
+end;
+
+
+function InterLockedIncrement64(var Target: Int64) : Int64; assembler; nostackframe;
+{ input:  address of target in r3 }
+{ output: target+1 in r3          }
+{ side-effect: target := target+1 }
+asm
+.LInterLockedIncLoop:
+        ldarx   r10,0,r3
+        addi    r10,r10,1
+        stdcx.  r10,0,r3
+        bne     .LInterLockedIncLoop
+        mr      r3,r10
+end;
+
+
+function InterLockedExchange64(var Target: Int64; Source : Int64) : Int64; assembler; nostackframe;
+{ input:  address of target in r3, source in r4 }
+{ output: target in r3                          }
+{ side-effect: target := source                 }
+asm
+.LInterLockedXchgLoop:
+        ldarx   r10,0,r3
+        stdcx.  r4,0,r3
+        bne     .LInterLockedXchgLoop
+        mr      r3,r10
+end;
+
+
+function InterLockedExchangeAdd64(var Target: Int64; Source : Int64) : Int64; assembler; nostackframe;
+{ input:  address of target in r3, source in r4 }
+{ output: target in r3                          }
+{ side-effect: target := target+source          }
+asm
+.LInterLockedXchgAddLoop:
+        ldarx   r10,0,r3
+        add     r10,r10,r4
+        stdcx.  r10,0,r3
+        bne     .LInterLockedXchgAddLoop
+        sub     r3,r10,r4
+end;
+
+function InterlockedCompareExchange64(var Target: Int64; NewValue: Int64; Comperand: Int64): Int64; assembler; nostackframe;
+{ input:  address of target in r3, newvalue in r4, comparand in r5 }
+{ output: value stored in target before entry of the function      }
+{ side-effect: NewValue stored in target if (target = comparand)   }
+asm
+.LInterlockedCompareExchangeLoop:
+  ldarx  r10,0,r3
+  sub    r9,r10,r5
+  addic  r9,r9,-1
+  subfe  r9,r9,r9
+  and    r8,r4,r9
+  andc   r7,r5,r9
+  or     r6,r7,r8
+  stdcx. r6,0,r3
+  bne .LInterlockedCompareExchangeLoop
+  mr     r3, r6
+end;