+ thlcgobj support of the managed open array initialization fixes of

    svn r17068,17071,17081,17136
  * changed all init_paras code in both thlcgobj and ncgutil to use
    location_get_data_ref() instead of direct a_load_loc_reg()/
    ref.base:=reg so it also works with the JVM target
  * changed all init_paras code so it works with targets that do
    not pass an implicit high parameter for open array (and a similar
    fix in ncgcal)
  + added support for initializing array (both regular and open)
    "out" parameters of reference counted types on the JVM target
    (the arrays will be initialised with nil rather than an empty
     array for implementation reasons, see comments in compproc.inc)
  * factored out calling of functions in the system unit directly
    from hlcgobj

git-svn-id: branches/jvmbackend@18421 -

.gitattributes

@@ -7346,10 +7346,12 @@ rtl/inc/wstrings.inc svneol=native#text/plain
 rtl/inc/wustrings.inc svneol=native#text/plain
 rtl/java/Makefile svneol=native#text/plain
 rtl/java/Makefile.fpc svneol=native#text/plain
+rtl/java/compproc.inc svneol=native#text/plain
 rtl/java/jdynarrh.inc svneol=native#text/plain
 rtl/java/jmathh.inc svneol=native#text/plain
 rtl/java/objpas.pp svneol=native#text/plain
 rtl/java/rtl.cfg svneol=native#text/plain
+rtl/java/rtti.inc svneol=native#text/plain
 rtl/java/system.pp svneol=native#text/plain
 rtl/jvm/makefile.cpu svneol=native#text/plain
 rtl/linux/Makefile svneol=native#text/plain

compiler/hlcg2ll.pas

@@ -333,6 +333,8 @@ unit hlcg2ll;
 
           procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
           procedure g_decrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
+          procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation;
+            const name: string);override;
           procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override;
           procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override;
 
@@ -1083,6 +1085,11 @@ procedure thlcg2ll.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; co
       cg.g_decrrefcount(list,t,ref);
     end;
 
+  procedure thlcg2ll.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
+    begin
+      cg.g_array_rtti_helper(list, t, ref, highloc, name);
+    end;
+
   procedure thlcg2ll.g_initialize(list: TAsmList; t: tdef; const ref: treference);
     begin
       cg.g_initialize(list,t,ref);

compiler/hlcgobj.pas

@@ -361,6 +361,8 @@ unit hlcgobj;
           procedure g_decrrefcount(list : TAsmList;t: tdef; const ref: treference);virtual;abstract;
           procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);virtual;abstract;
           procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);virtual;abstract;
+          procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation;
+            const name: string);virtual;abstract;
 
           {# Generates range checking code. It is to note
              that this routine does not need to be overridden,
@@ -1887,13 +1889,17 @@ implementation
         end;
     end;
 
+{ generates the code for incrementing the reference count of parameters and
+  initialize out parameters }
   { generates the code for incrementing the reference count of parameters and
     initialize out parameters }
   procedure thlcgobj.init_paras(p:TObject;arg:pointer);
     var
       href : treference;
-      tmpreg : tregister;
+      hsym : tparavarsym;
+      eldef : tdef;
       list : TAsmList;
+      highloc : tlocation;
       needs_inittable (*,
       do_trashing     *)  : boolean;
     begin
@@ -1917,7 +1923,26 @@ implementation
                    paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
                    begin
                      location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
-                     hlcg.g_incrrefcount(list,tparavarsym(p).vardef,href);
+                     if is_open_array(tparavarsym(p).vardef) then
+                       begin
+                         if paramanager.push_high_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption) then
+                           begin
+                             hsym:=tparavarsym(tsym(p).owner.Find('high'+tsym(p).name));
+                             if not assigned(hsym) then
+                               internalerror(201003032);
+                             highloc:=hsym.initialloc
+                           end
+                         else
+                           highloc.loc:=LOC_INVALID;
+                         { open arrays do not contain correct element count in their rtti,
+                           the actual count must be passed separately. }
+                         eldef:=tarraydef(tparavarsym(p).vardef).elementdef;
+                         if not assigned(hsym) then
+                           internalerror(201003031);
+                         g_array_rtti_helper(list,eldef,href,highloc,'FPC_ADDREF_ARRAY');
+                       end
+                     else
+                      g_incrrefcount(list,tparavarsym(p).vardef,href);
                    end;
                end;
            vs_out :
@@ -1925,12 +1950,10 @@ implementation
                if needs_inittable (*or
                   do_trashing*) then
                  begin
-                   tmpreg:=cg.getaddressregister(list);
-                   hlcg.a_load_loc_reg(list,tparavarsym(p).vardef,tparavarsym(p).vardef,tparavarsym(p).initialloc,tmpreg);
                    { we have no idea about the alignment at the callee side,
                      and the user also cannot specify "unaligned" here, so
                      assume worst case }
-                   reference_reset_base(href,tmpreg,0,1);
+                   location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,1);
 (*
                    if do_trashing and
                       { needs separate implementation to trash open arrays }
@@ -1944,21 +1967,36 @@ implementation
                        trash_reference(list,href,2);
 *)
                    if needs_inittable then
-                     hlcg.g_initialize(list,tparavarsym(p).vardef,href);
+                     begin
+                       if is_open_array(tparavarsym(p).vardef) then
+                         begin
+                           if paramanager.push_high_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption) then
+                             begin
+                               hsym:=tparavarsym(tsym(p).owner.Find('high'+tsym(p).name));
+                               if not assigned(hsym) then
+                                 internalerror(201003032);
+                               highloc:=hsym.initialloc
+                             end
+                           else
+                             highloc.loc:=LOC_INVALID;
+                           eldef:=tarraydef(tparavarsym(p).vardef).elementdef;
+                           g_array_rtti_helper(list,eldef,href,highloc,'FPC_INITIALIZE_ARRAY');
+                         end
+                       else
+                         g_initialize(list,tparavarsym(p).vardef,href);
+                     end;
                  end;
              end;
 (*
            else if do_trashing and
                    ([vo_is_funcret,vo_is_hidden_para] * tparavarsym(p).varoptions = [vo_is_funcret,vo_is_hidden_para]) then
                  begin
-                   tmpreg:=cg.getaddressregister(list);
-                   a_load_loc_reg(list,tparavarsym(p).vardef,tparavarsym(p).vardef,tparavarsym(p).initialloc,tmpreg);
                    { should always have standard alignment. If a function is assigned
                      to a non-aligned variable, the optimisation to pass this variable
                      directly as hidden function result must/cannot be performed
                      (see tcallnode.funcret_can_be_reused)
                    }
-                   reference_reset_base(href,tmpreg,0,
+                   location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,
                      used_align(tparavarsym(p).vardef.alignment,current_settings.alignment.localalignmin,current_settings.alignment.localalignmax));
                    { may be an open string, even if is_open_string() returns }
                    { false (for some helpers in the system unit)             }

compiler/jvm/hlcgcpu.pas

@@ -88,6 +88,7 @@ uses
 
       procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
       procedure g_decrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
+      procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); override;
       procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override;
       procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override;
 
@@ -172,6 +173,8 @@ uses
       { concatcopy helpers }
       procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
 
+      { generate a call to a routine in the system unit }
+      procedure g_call_system_proc(list: TAsmList; const procname: string);
     end;
 
   procedure create_hlcodegen;
@@ -1020,8 +1023,6 @@ implementation
     var
       procname: string;
       eledef: tdef;
-      pd: tprocdef;
-      srsym: tsym;
       ndim: longint;
     begin
       { load copy helper parameters on the stack }
@@ -1089,12 +1090,7 @@ implementation
         else
           procname:='FPC_COPY_JOBJECT_ARRAY';
       end;
-     srsym:=tsym(systemunit.find(procname));
-     if not assigned(srsym) or
-        (srsym.typ<>procsym) then
-       Message1(cg_f_unknown_compilerproc,procname);
-     pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
-     a_call_name(list,pd,pd.mangledname,false);
+     g_call_system_proc(list,procname);
      if ndim=1 then
        decstack(list,2)
      else
@@ -1235,9 +1231,46 @@ implementation
       // do nothing
     end;
 
+  procedure thlcgjvm.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
+    var
+      normaldim: longint;
+    begin
+      { only in case of initialisation, we have to set all elements to "empty" }
+      if name<>'FPC_INITIALIZE_ARRAY' then
+        exit;
+      { put array on the stack }
+      a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false));
+      { in case it's an open array whose elements are regular arrays, put the
+        dimension of the regular arrays on the stack (otherwise pass 0) }
+      normaldim:=0;
+      while (t.typ=arraydef) and
+            not is_dynamic_array(t) do
+        begin
+          inc(normaldim);
+          t:=tarraydef(t).elementdef;
+        end;
+      a_load_const_stack(list,s32inttype,normaldim,R_INTREGISTER);
+      { highloc is invalid, the length is part of the array in Java }
+      if is_wide_or_unicode_string(t) then
+        g_call_system_proc(list,'fpc_initialize_array_unicodestring')
+      else if is_dynamic_array(t) then
+        g_call_system_proc(list,'fpc_initialize_array_dynarr')
+      else
+        internalerror(2011031901);
+    end;
+
   procedure thlcgjvm.g_initialize(list: TAsmList; t: tdef; const ref: treference);
+    var
+      dummyloc: tlocation;
     begin
-      a_load_const_ref(list,t,0,ref);
+      if (t.typ=arraydef) and
+         not is_dynamic_array(t) then
+        begin
+          dummyloc.loc:=LOC_INVALID;
+          g_array_rtti_helper(list,tarraydef(t).elementdef,ref,dummyloc,'FPC_INITIALIZE_ARRAY')
+        end
+      else
+        a_load_const_ref(list,t,0,ref);
     end;
 
   procedure thlcgjvm.g_finalize(list: TAsmList; t: tdef; const ref: treference);
@@ -1649,6 +1682,19 @@ implementation
       list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(s)));
     end;
 
+  procedure thlcgjvm.g_call_system_proc(list: TAsmList; const procname: string);
+    var
+      srsym: tsym;
+      pd: tprocdef;
+    begin
+      srsym:=tsym(systemunit.find(procname));
+      if not assigned(srsym) or
+         (srsym.typ<>procsym) then
+        Message1(cg_f_unknown_compilerproc,procname);
+      pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
+      a_call_name(list,pd,pd.mangledname,false);
+    end;
+
   procedure create_hlcodegen;
     begin
       hlcg:=thlcgjvm.create;

compiler/ncgcal.pas

@@ -172,7 +172,8 @@ implementation
 
              { release memory for refcnt out parameters }
              if (parasym.varspez=vs_out) and
-                is_managed_type(left.resultdef) then
+                is_managed_type(left.resultdef) and
+                not(target_info.system in systems_garbage_collected_managed_types) then
                begin
                  hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,left.location,href,false,sizeof(pint));
                  if is_open_array(resultdef) then

compiler/ncgutil.pas

@@ -1553,7 +1553,6 @@ implementation
         href : treference;
         hsym : tparavarsym;
         eldef : tdef;
-        tmpreg : tregister;
         list : TAsmList;
         needs_inittable,
         do_trashing       : boolean;
@@ -1595,12 +1594,10 @@ implementation
                  if needs_inittable or
                     do_trashing then
                    begin
-                     tmpreg:=cg.getaddressregister(list);
-                     cg.a_load_loc_reg(list,OS_ADDR,tparavarsym(p).initialloc,tmpreg);
                      { we have no idea about the alignment at the callee side,
                        and the user also cannot specify "unaligned" here, so
                        assume worst case }
-                     reference_reset_base(href,tmpreg,0,1);
+                     hlcg.location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,1);
                      if do_trashing and
                         { needs separate implementation to trash open arrays }
                         { since their size is only known at run time         }
@@ -1629,14 +1626,12 @@ implementation
              else if do_trashing and
                      ([vo_is_funcret,vo_is_hidden_para] * tparavarsym(p).varoptions = [vo_is_funcret,vo_is_hidden_para]) then
                    begin
-                     tmpreg:=cg.getaddressregister(list);
-                     cg.a_load_loc_reg(list,OS_ADDR,tparavarsym(p).initialloc,tmpreg);
                      { should always have standard alignment. If a function is assigned
                        to a non-aligned variable, the optimisation to pass this variable
                        directly as hidden function result must/cannot be performed
                        (see tcallnode.funcret_can_be_reused)
                      }
-                     reference_reset_base(href,tmpreg,0,
+                     hlcg.location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,
                        used_align(tparavarsym(p).vardef.alignment,current_settings.alignment.localalignmin,current_settings.alignment.localalignmax));
                      { may be an open string, even if is_open_string() returns }
                      { false (for some helpers in the system unit)             }
@@ -1658,6 +1653,7 @@ implementation
         href : treference;
         hsym : tparavarsym;
         eldef : tdef;
+        highloc : tlocation;
       begin
         if not(tsym(p).typ=paravarsym) then
           exit;
@@ -1670,11 +1666,17 @@ implementation
               hlcg.location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).localloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
               if is_open_array(tparavarsym(p).vardef) then
                 begin
-                  hsym:=tparavarsym(tsym(p).owner.Find('high'+tsym(p).name));
+                  if paramanager.push_high_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption) then
+                    begin
+                      hsym:=tparavarsym(tsym(p).owner.Find('high'+tsym(p).name));
+                      if not assigned(hsym) then
+                        internalerror(201003032);
+                      highloc:=hsym.initialloc
+                    end
+                  else
+                    highloc.loc:=LOC_INVALID;
                   eldef:=tarraydef(tparavarsym(p).vardef).elementdef;
-                  if not assigned(hsym) then
-                    internalerror(201003032);
-                  cg.g_array_rtti_helper(list,eldef,href,hsym.initialloc,'FPC_DECREF_ARRAY');
+                  hlcg.g_array_rtti_helper(list,eldef,href,highloc,'FPC_DECREF_ARRAY');
                 end
               else
                 hlcg.g_decrrefcount(list,tparavarsym(p).vardef,href);

rtl/java/compproc.inc

@@ -0,0 +1,55 @@
+{
+    This file is part of the Free Pascal Run time library.
+    Copyright (c) 1999-2000 by the Free Pascal development team
+
+    This file contains the declarations of internal compiler helper
+    routines. That means you can *NOT* call these directly, as they may
+    be changed or even removed at any time. The only reason they are
+    included in the interface of the system unit, is so that the
+    compiler doesn't need special code to access their parameter
+    list information etc.
+
+    Note that due to the "compilerproc" directive, it isn't even possible
+    to use these routines in your programs.
+
+    See the File COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$ifdef FPC_HAS_FEATURE_RTTI}
+Procedure fpc_Initialize (Data,TypeInfo : pointer); compilerproc;
+Procedure fpc_finalize (Data,TypeInfo: Pointer); compilerproc;
+Procedure fpc_Addref (Data,TypeInfo : Pointer); compilerproc;
+Procedure fpc_DecRef (Data,TypeInfo : Pointer);  compilerproc;
+procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); compilerproc;
+procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); compilerproc;
+procedure fpc_addref_array(data,typeinfo: pointer; count: SizeInt); compilerproc;
+procedure fpc_decref_array(data,typeinfo: pointer; count: sizeint); compilerproc;
+Function fpc_Copy (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc;
+Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
+{$endif FPC_HAS_FEATURE_RTTI}
+{ normalarrdim contains the number of dimensions
+  a regular array, if any, that contains these unicodestrings. E.g.:
+   type
+     tarr = array[1..10,2..9] of unicodestring;
+
+   procedure test(out arr: array of tarr);
+    -> normalarrdim will be 2
+
+  Initialises with nil rather than with empty arrays, because there does not
+  appear to be a generic way to pass an iniitialised (empty) array object and
+  then clone it for every array position, except for slow serialization (array
+  instances are clonable in Java, but they don't inherit from a base class other
+  than java.lang.Object (in which clone is protected) and they only implement
+  the formal interfaces Clonable and Serializeable (which don't expose any
+  particular methods). This means that we cannot cast arrays to a generic class
+  type that supports cloning (except if we add support for calling methods on
+  dynamic array types, and add an extra parameter to determine the first
+  level elements types of the array) }
+procedure fpc_initialize_array_dynarr(arr: TJObjectArray; normalarrdim: longint);compilerproc;
+

rtl/java/rtti.inc

@@ -0,0 +1,32 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2011 by Jonas Maebe
+    member of the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+procedure fpc_initialize_array_dynarr_intern(arr: TJObjectArray; normalarrdim: longint); external name 'fpc_initialize_array_dynarr';
+
+procedure fpc_initialize_array_dynarr(arr: TJObjectArray; normalarrdim: longint);compilerproc;
+  var
+    i: longint;
+  begin
+    if normalarrdim > 0 then
+      begin
+        for i:=low(arr) to high(arr) do
+          fpc_initialize_array_dynarr_intern(TJObjectArray(arr[i]),normalarrdim-1);
+      end
+    else
+      begin
+        for i:=low(arr) to high(arr) do
+          arr[i]:=nil;
+      end;
+  end;
+

rtl/java/system.pp

@@ -26,6 +26,8 @@ Unit system;
 {$implicitexceptions off}
 {$mode objfpc}
 
+{$undef FPC_HAS_FEATURE_RTTI}
+
 Type
   { The compiler has all integer types defined internally. Here
     we define only aliases }
@@ -122,6 +124,8 @@ type
 {$i jmathh.inc}
 {$i jdynarrh.inc}
 
+{$i compproc.inc}
+
 {*****************************************************************************}
                                  implementation
 {*****************************************************************************}
@@ -144,6 +148,8 @@ type
  **********************************************************************
 }
 
+{$i rtti.inc}
+
 function min(a,b : longint) : longint;
   begin
      if a<=b then