paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-24 04:39:10 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ thlcgobj support of the managed open array initialization fixes of

Browse Source 
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 -
This commit is contained in:
Jonas Maebe 2011-08-20 07:58:14 +00:00
parent 254636ab84
commit 5abf6d0aa4
9 changed files with 220 additions and 31 deletions

2
.gitattributes vendored
View File

@ -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

7
compiler/hlcg2ll.pas
View File

@ -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);

56
compiler/hlcgobj.pas
View File

@ -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) }

66
compiler/jvm/hlcgcpu.pas
View File

@ -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_initialize(list: TAsmList; t: tdef; const ref: treference);
procedure thlcgjvm.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
var
normaldim: longint;
begin
a_load_const_ref(list,t,0,ref);
{ 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
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;

3
compiler/ncgcal.pas
View File

@ -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

24
compiler/ncgutil.pas
View File

@ -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);

55
rtl/java/compproc.inc Normal file
View File

@ -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;

32
rtl/java/rtti.inc Normal file
View File

@ -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;

6
rtl/java/system.pp
View File

@ -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