paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2026-01-06 23:40:39 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ support for regular arrays and open arrays

Browse Source 
o support for copying value parameters at the callee side if they were
     passed by reference in hlcg
   o JVM g_concatcopy() implementation for arrays
   o moved code to get length of an array from njvminl to hlcgcpu so it can
     be reused elsewhere as well
   o export array copy helpers from system unit for use when assigning one
     array to another
   o some generic support for types that are normally not implicit pointers,
     but which are for the JVM target (such as normal arrays)
  * handle assigning nil to a dynamic array by generating a setlength(x,0)
    node instead of by hardcoding a call to fpc_dynarray_clear, so
    target-specific code can handle it if required
  * hook up gethltemp() for JVM ttgjvm so array temps are properly
    allocated

git-svn-id: branches/jvmbackend@18388 -
This commit is contained in:
Jonas Maebe 2011-08-20 07:55:27 +00:00
parent 0a3a62811b
commit 2c313e397e
19 changed files with 676 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -225,6 +225,7 @@ compiler/jvm/njvmcnv.pas svneol=native#text/plain
compiler/jvm/njvmcon.pas svneol=native#text/plain
compiler/jvm/njvmflw.pas svneol=native#text/plain
compiler/jvm/njvminl.pas svneol=native#text/plain
compiler/jvm/njvmld.pas svneol=native#text/plain
compiler/jvm/njvmmat.pas svneol=native#text/plain
compiler/jvm/njvmmem.pas svneol=native#text/plain
compiler/jvm/njvmutil.pas svneol=native#text/plain

28
compiler/hlcg2ll.pas
View File

@ -328,8 +328,8 @@ unit hlcg2ll;
@param(dest Destination reference of copy)
}
// procedure g_copyshortstring(list : TAsmList;const source,dest : treference;len:byte);
// procedure g_copyvariant(list : TAsmList;const source,dest : treference);
procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);override;
procedure g_copyvariant(list : TAsmList;const source,dest : treference;vardef:tvariantdef);override;
procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
procedure g_decrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
@ -349,8 +349,8 @@ unit hlcg2ll;
procedure g_overflowcheck(list: TAsmList; const Loc:tlocation; def:tdef); override;
procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation);override;
// procedure g_copyvaluepara_openarray(list : TAsmList;const ref:treference;const lenloc:tlocation;elesize:aint;destreg:tregister);override;
// procedure g_releasevaluepara_openarray(list : TAsmList;const l:tlocation);override;
procedure g_copyvaluepara_openarray(list : TAsmList;const ref:treference;const lenloc:tlocation;arrdef: tarraydef;destreg:tregister);override;
procedure g_releasevaluepara_openarray(list : TAsmList;arrdef: tarraydef;const l:tlocation);override;
{# Emits instructions when compilation is done in profile
mode (this is set as a command line option). The default
@ -1063,6 +1063,16 @@ procedure thlcg2ll.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; co
cg.g_concatcopy_unaligned(list,source,dest,size.size);
end;
procedure thlcg2ll.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef);
begin
cg.g_copyshortstring(list,source,dest,strdef.len);
end;
procedure thlcg2ll.g_copyvariant(list: TAsmList; const source, dest: treference; vardef: tvariantdef);
begin
cg.g_copyvariant(list,source,dest);
end;
procedure thlcg2ll.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference);
begin
cg.g_incrrefcount(list,t,ref);
@ -1098,6 +1108,16 @@ procedure thlcg2ll.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; co
cg.g_overflowCheck_loc(list,loc,def,ovloc);
end;
procedure thlcg2ll.g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister);
begin
cg.g_copyvaluepara_openarray(list,ref,lenloc,arrdef.elesize,destreg);
end;
procedure thlcg2ll.g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation);
begin
cg.g_releasevaluepara_openarray(list,l);
end;
procedure thlcg2ll.g_profilecode(list: TAsmList);
begin
cg.g_profilecode(list);

131
compiler/hlcgobj.pas
View File

@ -354,8 +354,8 @@ unit hlcgobj;
@param(dest Destination reference of copy)
}
// procedure g_copyshortstring(list : TAsmList;const source,dest : treference;len:byte);
// procedure g_copyvariant(list : TAsmList;const source,dest : treference);
procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);virtual;abstract;
procedure g_copyvariant(list : TAsmList;const source,dest : treference;vardef:tvariantdef);virtual;abstract;
procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);virtual;abstract;
procedure g_decrrefcount(list : TAsmList;t: tdef; const ref: treference);virtual;abstract;
@ -375,8 +375,8 @@ unit hlcgobj;
procedure g_overflowcheck(list: TAsmList; const Loc:tlocation; def:tdef); virtual; abstract;
procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation);virtual; abstract;
// procedure g_copyvaluepara_openarray(list : TAsmList;const ref:treference;const lenloc:tlocation;elesize:aint;destreg:tregister);virtual;
// procedure g_releasevaluepara_openarray(list : TAsmList;const l:tlocation);virtual;
procedure g_copyvaluepara_openarray(list : TAsmList;const ref:treference;const lenloc:tlocation;arrdef: tarraydef;destreg:tregister);virtual;abstract;
procedure g_releasevaluepara_openarray(list : TAsmList;arrdef: tarraydef;const l:tlocation);virtual;abstract;
{# Emits instructions when compilation is done in profile
mode (this is set as a command line option). The default
@ -430,15 +430,21 @@ unit hlcgobj;
// procedure location_force_mmregscalar(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);virtual;abstract;
// procedure location_force_mmreg(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);virtual;abstract;
{ Retrieve the location of the data pointed to in location l, when the location is
a register it is expected to contain the address of the data }
procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);virtual;
procedure maketojumpbool(list:TAsmList; p : tnode);virtual;
procedure gen_proc_symbol(list:TAsmList);virtual;
procedure gen_proc_symbol_end(list:TAsmList);virtual;
procedure gen_load_para_value(list:TAsmList);virtual;
private
protected
{ helpers called by gen_load_para_value }
procedure g_copyvalueparas(p:TObject;arg:pointer);virtual;
procedure gen_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation;const cgpara: tcgpara;locintsize: longint);virtual;
procedure init_paras(p:TObject;arg:pointer);
protected
{ Some targets have to put "something" in the function result
location if it's not initialised by the Pascal code, e.g.
@ -1727,6 +1733,33 @@ implementation
end;
end;
procedure thlcgobj.location_get_data_ref(list: TAsmList; def: tdef; const l: tlocation; var ref: treference; loadref: boolean; alignment: longint);
begin
case l.loc of
LOC_REGISTER,
LOC_CREGISTER :
begin
if not loadref then
internalerror(200410231);
reference_reset_base(ref,l.register,0,alignment);
end;
LOC_REFERENCE,
LOC_CREFERENCE :
begin
if loadref then
begin
reference_reset_base(ref,cg.getaddressregister(list),0,alignment);
{ it's a pointer to def }
hlcg.a_load_ref_reg(list,voidpointertype,voidpointertype,l.reference,ref.base);
end
else
ref:=l.reference;
end;
else
internalerror(200309181);
end;
end;
procedure thlcgobj.maketojumpbool(list: TAsmList; p: tnode);
{
produces jumps to true respectively false labels using boolean expressions
@ -1856,7 +1889,7 @@ implementation
{ generates the code for incrementing the reference count of parameters and
initialize out parameters }
procedure init_paras(p:TObject;arg:pointer);
procedure thlcgobj.init_paras(p:TObject;arg:pointer);
var
href : treference;
tmpreg : tregister;
@ -1883,7 +1916,7 @@ implementation
if not((tparavarsym(p).vardef.typ=variantdef) and
paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
begin
location_get_data_ref(list,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
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);
end;
end;
@ -1958,7 +1991,7 @@ implementation
{ generate copies of call by value parameters, must be done before
the initialization and body is parsed because the refcounts are
incremented using the local copies }
// current_procinfo.procdef.parast.SymList.ForEachCall(@copyvalueparas,list);
current_procinfo.procdef.parast.SymList.ForEachCall(@g_copyvalueparas,list);
if not(po_assembler in current_procinfo.procdef.procoptions) then
begin
@ -1979,6 +2012,86 @@ implementation
end;
end;
procedure thlcgobj.g_copyvalueparas(p: TObject; arg: pointer);
var
href : treference;
hreg : tregister;
list : TAsmList;
hsym : tparavarsym;
l : longint;
highloc,
localcopyloc : tlocation;
begin
list:=TAsmList(arg);
if (tsym(p).typ=paravarsym) and
(tparavarsym(p).varspez=vs_value) and
(paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
begin
{ we have no idea about the alignment at the caller side }
location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,1);
if is_open_array(tparavarsym(p).vardef) or
is_array_of_const(tparavarsym(p).vardef) then
begin
{ cdecl functions don't have a high pointer so it is not possible to generate
a local copy }
if not(current_procinfo.procdef.proccalloption in cdecl_pocalls) 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(2011020506);
highloc:=hsym.initialloc
end
else
highloc.loc:=LOC_INVALID;
hreg:=cg.getaddressregister(list);
if not is_packed_array(tparavarsym(p).vardef) then
g_copyvaluepara_openarray(list,href,highloc,tarraydef(tparavarsym(p).vardef),hreg)
else
internalerror(2011020507);
// cg.g_copyvaluepara_packedopenarray(list,href,hsym.intialloc,tarraydef(tparavarsym(p).vardef).elepackedbitsize,hreg);
a_load_reg_loc(list,tparavarsym(p).vardef,tparavarsym(p).vardef,hreg,tparavarsym(p).initialloc);
end;
end
else
begin
{ Allocate space for the local copy }
l:=tparavarsym(p).getsize;
localcopyloc.loc:=LOC_REFERENCE;
localcopyloc.size:=int_cgsize(l);
tg.GetLocal(list,l,tparavarsym(p).vardef,localcopyloc.reference);
{ Copy data }
if is_shortstring(tparavarsym(p).vardef) then
begin
{ this code is only executed before the code for the body and the entry/exit code is generated
so we're allowed to include pi_do_call here; after pass1 is run, this isn't allowed anymore
}
include(current_procinfo.flags,pi_do_call);
g_copyshortstring(list,href,localcopyloc.reference,tstringdef(tparavarsym(p).vardef))
end
else if tparavarsym(p).vardef.typ=variantdef then
begin
{ this code is only executed before the code for the body and the entry/exit code is generated
so we're allowed to include pi_do_call here; after pass1 is run, this isn't allowed anymore
}
include(current_procinfo.flags,pi_do_call);
g_copyvariant(list,href,localcopyloc.reference,tvariantdef(tparavarsym(p).vardef))
end
else
begin
{ pass proper alignment info }
localcopyloc.reference.alignment:=tparavarsym(p).vardef.alignment;
g_concatcopy(list,tparavarsym(p).vardef,href,localcopyloc.reference);
end;
{ update localloc of varsym }
tg.Ungetlocal(list,tparavarsym(p).localloc.reference);
tparavarsym(p).localloc:=localcopyloc;
tparavarsym(p).initialloc:=localcopyloc;
end;
end;
end;
procedure thlcgobj.gen_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation; const cgpara: tcgpara; locintsize: longint);
begin
case l.loc of

7
compiler/jvm/cpunode.pas
View File

@ -32,9 +32,8 @@ implementation
uses
ncgbas,ncgflw,ncgcnv,ncgld,ncgmem,ncgcon,ncgset,
ncgadd, ncgcal,ncgmat,ncginl,
njvmadd,njvmcal,njvmmat,njvmcnv,njvmcon,njvminl,njvmmem,njvmflw
{ ncpuadd,ncpucall,ncpumat,ncpuinln,ncpucnv,ncpuset, }
{ this not really a node }
{ rgcpu},tgcpu,njvmutil;
njvmadd,njvmcal,njvmmat,njvmcnv,njvmcon,njvminl,njvmmem,njvmflw,njvmld
{ these are not really nodes }
,rgcpu,tgcpu,njvmutil;
end.

27
compiler/jvm/cpupara.pas
View File

@ -35,7 +35,9 @@ interface
{ TJVMParaManager }
TJVMParaManager=class(TParaManager)
function push_high_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override;
function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override;
function push_size(varspez: tvarspez; def: tdef; calloption: tproccalloption): longint;override;
{Returns a structure giving the information on the storage of the parameter
(which must be an integer parameter)
@param(nr Parameter number of routine, starting from 1)}
@ -55,7 +57,7 @@ implementation
uses
cutils,verbose,systems,
defutil,
defutil,jvmdef,
cgobj;
@ -65,12 +67,31 @@ implementation
internalerror(2010121001);
end;
function TJVMParaManager.push_high_param(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean;
begin
{ we don't need a separate high parameter, since all arrays in Java
have an implicit associated length }
if not is_open_array(def) then
result:=inherited
else
result:=false;
end;
{ true if a parameter is too large to copy and only the address is pushed }
function TJVMParaManager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
begin
{ call by reference does not exist in Java bytecode }
result:=false;
result:=jvmimplicitpointertype(def);
end;
function TJVMParaManager.push_size(varspez: tvarspez; def: tdef; calloption: tproccalloption): longint;
begin
{ all aggregate types are emulated using indirect pointer types }
if def.typ in [arraydef,recorddef,setdef,stringdef] then
result:=4
else
result:=inherited;
end;

269
compiler/jvm/hlcgcpu.pas
View File

@ -73,6 +73,8 @@ uses
procedure a_jmp_always(list : TAsmList;l: tasmlabel); override;
procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override;
procedure a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference); override;
procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); override;
procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); override;
@ -89,6 +91,10 @@ uses
procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override;
procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override;
procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);override;
procedure g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); override;
procedure g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); override;
{ JVM-specific routines }
procedure a_load_stack_reg(list : TAsmList;size: tdef;reg: tregister);
@ -118,6 +124,9 @@ uses
evaluation stack, and creates a new array of type arrdef with these
dimensions }
procedure g_newarray(list : TAsmList; arrdef: tdef; initdim: longint);
{ gets the length of the array whose reference is stored in arrloc,
and puts it on the evaluation stack }
procedure g_getarraylen(list : TAsmList; const arrloc: tlocation);
{ this routine expects that all values are already massaged into the
required form (sign bits xor'ed for gt/lt comparisons for OS_32/OS_64,
@ -159,6 +168,10 @@ uses
procedure maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean);
{ common implementation of a_call_* }
procedure a_call_name_intern(list : TAsmList;pd : tprocdef;const s : string; inheritedcall: boolean);
{ concatcopy helpers }
procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
end;
procedure create_hlcodegen;
@ -175,8 +188,8 @@ implementation
verbose,cutils,globals,
defutil,
aasmtai,aasmcpu,
symconst,jvmdef,
procinfo,cgcpu;
symconst,symtable,symsym,jvmdef,
procinfo,cgcpu,tgobj;
const
TOpCG2IAsmOp : array[topcg] of TAsmOp=( { not = xor -1 }
@ -595,6 +608,46 @@ implementation
end;
end;
procedure thlcgjvm.g_getarraylen(list: TAsmList; const arrloc: tlocation);
var
nillab,endlab: tasmlabel;
begin
{ inline because we have to use the arraylength opcode, which
cannot be represented directly in Pascal. Even though the JVM
supports allocated arrays with length=0, we still also have to
check for nil pointers because even if FPC always generates
allocated empty arrays under all circumstances, external Java
code could pass in nil pointers.
Note that this means that assigned(arr) can be different from
length(arr)<>0 for dynamic arrays when targeting the JVM.
}
current_asmdata.getjumplabel(nillab);
current_asmdata.getjumplabel(endlab);
{ if assigned(arr) ... }
a_load_loc_stack(list,java_jlobject,arrloc);
list.concat(taicpu.op_none(a_dup));
incstack(list,1);
list.concat(taicpu.op_none(a_aconst_null));
incstack(list,1);
list.concat(taicpu.op_sym(a_if_acmpeq,nillab));
decstack(list,2);
{ ... then result:=arraylength(arr) ... }
list.concat(taicpu.op_none(a_arraylength));
a_jmp_always(list,endlab);
{ ... else result:=0 }
a_label(list,nillab);
list.concat(taicpu.op_none(a_pop));
decstack(list,1);
list.concat(taicpu.op_none(a_iconst_0));
incstack(list,1);
a_label(list,endlab);
end;
procedure thlcgjvm.a_cmp_stack_label(list: TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel);
const
opcmp2icmp: array[topcmp] of tasmop = (A_None,
@ -859,7 +912,12 @@ implementation
procedure thlcgjvm.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister);
begin
internalerror(2010120534);
{ only allowed for types that are not implicit pointers in Pascal (in
that case, ref contains a pointer to the actual data and we simply
return that pointer) }
if not jvmimplicitpointertype(fromsize) then
internalerror(2010120534);
a_load_ref_reg(list,java_jlobject,java_jlobject,ref,r);
end;
procedure thlcgjvm.a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; reg: TRegister);
@ -957,6 +1015,115 @@ implementation
list.concat(taicpu.op_sym(a_goto,current_asmdata.RefAsmSymbol(l.name)));
end;
procedure thlcgjvm.concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
var
procname: string;
eledef: tdef;
pd: tprocdef;
srsym: tsym;
ndim: longint;
begin
{ load copy helper parameters on the stack }
a_load_ref_stack(list,java_jlobject,source,prepare_stack_for_ref(list,source,false));
a_load_ref_stack(list,java_jlobject,dest,prepare_stack_for_ref(list,dest,false));
{ call copy helper }
eledef:=tarraydef(size).elementdef;
ndim:=1;
case eledef.typ of
orddef:
begin
case torddef(eledef).ordtype of
pasbool8,s8bit,u8bit,bool8bit,uchar:
procname:='FPC_COPY_JBYTE_ARRAY';
s16bit,u16bit,bool16bit,pasbool16:
procname:='FPC_COPY_JSHORT_ARRAY';
uwidechar:
procname:='FPC_COPY_JCHAR_ARRAY';
s32bit,u32bit,bool32bit,pasbool32:
procname:='FPC_COPY_JINT_ARRAY';
s64bit,u64bit,bool64bit,pasbool64,scurrency:
procname:='FPC_COPY_JLONG_ARRAY';
else
internalerror(2011020504);
end;
end;
floatdef:
case tfloatdef(eledef).floattype of
s32real:
procname:='FPC_COPY_JFLOAT_ARRAY';
s64real:
procname:='FPC_COPY_JDOUBLE_ARRAY';
end;
arraydef:
begin
{ call fpc_setlength_dynarr_multidim with deepcopy=true, and extra
parameters }
while (eledef.typ=arraydef) and
not is_dynamic_array(eledef) do
begin
eledef:=tarraydef(eledef).elementdef;
inc(ndim)
end;
if (ndim=1) then
procname:='FPC_COPY_JOBJECT_ARRAY'
else
begin
{ deepcopy=true }
a_load_const_stack(list,pasbool8type,1,R_INTREGISTER);
{ ndim }
a_load_const_stack(list,s32inttype,ndim,R_INTREGISTER);
{ eletype }
a_load_const_stack(list,cwidechartype,ord(jvmarrtype_setlength(eledef)),R_INTREGISTER);
procname:='FPC_SETLENGTH_DYNARR_MULTIDIM';
end;
end;
setdef,
recorddef,
stringdef,
variantdef:
begin
{ todo: make a (recursive for records) deep copy, not sure yet how... }
internalerror(2011020505);
end;
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);
if ndim=1 then
decstack(list,2)
else
begin
decstack(list,4);
{ pop return value, must be the same as dest }
list.concat(taicpu.op_none(a_pop));
decstack(list,1);
end;
end;
procedure thlcgjvm.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference);
var
handled: boolean;
begin
handled:=false;
case size.typ of
arraydef:
begin
if not is_dynamic_array(size) then
begin
concatcopy_normal_array(list,size,source,dest);
handled:=true;
end;
end;
end;
if not handled then
inherited;
end;
procedure thlcgjvm.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference);
var
dstack_slots: longint;
@ -1077,6 +1244,90 @@ implementation
// do nothing
end;
procedure thlcgjvm.location_get_data_ref(list: TAsmList; def: tdef; const l: tlocation; var ref: treference; loadref: boolean; alignment: longint);
var
tmploc: tlocation;
begin
{ This routine is a combination of a generalised a_loadaddr_ref_reg()
that also works for addresses in registers (in case loadref is false)
and of a_load_ref_reg (in case loadref is true). It is used for
a) getting the address of managed types
b) getting to the actual data of value types that are passed by
reference by the compiler (and then get a local copy at the caller
side). Normally, depending on whether this reference is passed in a
register or reference, we either need a reference with that register
as base or load the address in that reference and use that as a new
base.
Since the JVM cannot take the address of anything, all
"pass-by-reference" value parameters (which are always aggregate types)
are already simply the implicit pointer to the data (since arrays,
records, etc are already internally implicit pointers). This means
that if "loadref" is true, we must simply return this implicit pointer.
If it is false, we are supposed the take the address of this implicit
pointer, which is not possible.
However, managed types are also implicit pointers in Pascal, so in that
case "taking the address" again consists of simply returning the
implicit pointer/current value.
}
if not loadref then
begin
if not is_managed_type(def) then
internalerror(2011020601);
end
else
begin
if not jvmimplicitpointertype(def) then
internalerror(2011020602);
end;
case l.loc of
LOC_REGISTER,
LOC_CREGISTER :
begin
{ the implicit pointer is in a register and has to be in a
reference -> create a reference and put it there }
tmploc:=l;
location_force_mem(list,tmploc,java_jlobject);
ref:=tmploc.reference;
end;
LOC_REFERENCE,
LOC_CREFERENCE :
begin
ref:=l.reference;
end;
else
internalerror(2011020603);
end;
end;
procedure thlcgjvm.g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister);
var
localref: treference;
arrloc: tlocation;
stackslots: longint;
begin
{ temporary reference for passing to concatcopy }
tg.gethltemp(list,java_jlobject,java_jlobject.size,tt_persistent,localref);
stackslots:=prepare_stack_for_ref(list,localref,false);
{ create the local copy of the array (lenloc is invalid, get length
directly from the array) }
location_reset_ref(arrloc,LOC_REFERENCE,OS_ADDR,sizeof(pint));
arrloc.reference:=ref;
g_getarraylen(list,arrloc);
g_newarray(list,arrdef,1);
a_load_stack_ref(list,java_jlobject,localref,stackslots);
{ copy the source array to the destination }
g_concatcopy(list,arrdef,ref,localref);
{ and put the array pointer in the register as expected by the caller }
a_load_ref_reg(list,java_jlobject,java_jlobject,localref,destreg);
end;
procedure thlcgjvm.g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation);
begin
// do nothing, long live garbage collection!
end;
procedure thlcgjvm.a_load_stack_reg(list: TAsmList; size: tdef; reg: tregister);
var
opc: tasmop;
@ -1084,6 +1335,9 @@ implementation
begin
opc:=loadstoreopc(size,false,false,finishandval);
list.concat(taicpu.op_reg(opc,reg));
{ avoid problems with getting the size of an open array etc }
if jvmimplicitpointertype(size) then
size:=java_jlobject;
decstack(list,1+ord(size.size>4));
end;
@ -1100,6 +1354,9 @@ implementation
list.concat(taicpu.op_ref(opc,ref))
else
list.concat(taicpu.op_none(opc));
{ avoid problems with getting the size of an open array etc }
if jvmimplicitpointertype(size) then
size:=java_jlobject;
decstack(list,1+ord(size.size>4)+extra_slots);
end;
@ -1112,6 +1369,9 @@ implementation
list.concat(taicpu.op_reg(opc,reg));
if finishandval<>-1 then
a_op_const_stack(list,OP_AND,size,finishandval);
{ avoid problems with getting the size of an open array etc }
if jvmimplicitpointertype(size) then
size:=java_jlobject;
incstack(list,1+ord(size.size>4));
end;
@ -1130,6 +1390,9 @@ implementation
list.concat(taicpu.op_none(opc));
if finishandval<>-1 then
a_op_const_stack(list,OP_AND,size,finishandval);
{ avoid problems with getting the size of an open array etc }
if jvmimplicitpointertype(size) then
size:=java_jlobject;
incstack(list,1+ord(size.size>4)-extra_slots);
end;

61
compiler/jvm/njvminl.pas
View File

@ -89,7 +89,8 @@ implementation
function tjvminlinenode.typecheck_length(var handled: boolean): tnode;
begin
typecheckpass(left);
if is_dynamic_array(left.resultdef) then
if is_dynamic_array(left.resultdef) or
is_open_array(left.resultdef) then
begin
resultdef:=s32inttype;
result:=nil;
@ -101,7 +102,8 @@ implementation
function tjvminlinenode.typecheck_high(var handled: boolean): tnode;
begin
typecheckpass(left);
if is_dynamic_array(left.resultdef) then
if is_dynamic_array(left.resultdef) or
is_open_array(left.resultdef) then
begin
{ replace with pred(length(arr)) }
result:=cinlinenode.create(in_pred_x,false,
@ -247,6 +249,18 @@ implementation
eledef:=tarraydef(eledef).elementdef;
ppn:=tcallparanode(ppn).right;
end;
{ in case it's a dynamic array of static arrays, we must also allocate
the static arrays! }
while (eledef.typ=arraydef) and
not is_dynamic_array(eledef) do
begin
inc(ndims);
tcallparanode(ppn).right:=
ccallparanode.create(
genintconstnode(tarraydef(eledef).elecount),nil);
ppn:=tcallparanode(ppn).right;
eledef:=tarraydef(eledef).elementdef;
end;
{ prepend type parameter for the array }
newparas:=ccallparanode.create(ctypenode.create(left.resultdef),newparas);
ttypenode(tcallparanode(newparas).left).allowed:=true;
@ -268,8 +282,11 @@ implementation
assignmenttarget:=tcallparanode(left).left.getcopy;
newparas:=left;
left:=nil;
{ if more than 1 dimension, typecast to generic array of tobject }
if ndims>1 then
{ if more than 1 dimension, or if 1 dimention of a non-primitive type,
typecast to generic array of tobject }
setlenroutine:=jvmarrtype(eledef,primitive);
if (ndims>1) or
not primitive then
begin
objarraydef:=search_system_type('TJOBJECTARRAY').typedef;
tcallparanode(newparas).left:=ctypeconvnode.create_explicit(tcallparanode(newparas).left,objarraydef);
@ -294,7 +311,6 @@ implementation
end
else
begin
setlenroutine:=jvmarrtype(eledef,primitive);
if not primitive then
setlenroutine:='OBJECT'
else
@ -318,43 +334,14 @@ implementation
procedure tjvminlinenode.second_length;
var
nillab,endlab: tasmlabel;
begin
if is_dynamic_array(left.resultdef) then
if is_dynamic_array(left.resultdef) or
is_open_array(left.resultdef) then
begin
{ inline because we have to use the arraylength opcode, which
cannot be represented directly in Pascal. Even though the JVM
supports allocated arrays with length=0, we still also have to
check for nil pointers because even if FPC always generates
allocated empty arrays under all circumstances, external Java
code could pass in nil pointers.
Note that this means that assigned(arr) can be different from
length(arr)<>0 when targeting the JVM.
}
{ if assigned(arr) then result:=arraylength(arr) else result:=0 }
location_reset(location,LOC_REGISTER,OS_S32);
location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,s32inttype);
secondpass(left);
current_asmdata.getjumplabel(nillab);
current_asmdata.getjumplabel(endlab);
thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
current_asmdata.CurrAsmList.concat(taicpu.op_none(a_dup));
thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
current_asmdata.CurrAsmList.concat(taicpu.op_none(a_aconst_null));
thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_if_acmpeq,nillab));
thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,2);
current_asmdata.CurrAsmList.concat(taicpu.op_none(a_arraylength));
hlcg.a_jmp_always(current_asmdata.CurrAsmList,endlab);
hlcg.a_label(current_asmdata.CurrAsmList,nillab);
current_asmdata.CurrAsmList.concat(taicpu.op_none(a_pop));
thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
current_asmdata.CurrAsmList.concat(taicpu.op_none(a_iconst_0));
thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
hlcg.a_label(current_asmdata.CurrAsmList,endlab);
thlcgjvm(hlcg).g_getarraylen(current_asmdata.CurrAsmList,left.location);
thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
end
else

54
compiler/jvm/njvmld.pas Normal file
View File

@ -0,0 +1,54 @@
{
Copyright (c) 2011 by Jonas Maebe
Generate JVM assembler for nodes that handle loads and assignments
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit njvmld;
{$I fpcdefs.inc}
interface
uses
node, ncgld;
type
tjvmloadnode = class(tcgloadnode)
function is_addr_param_load: boolean; override;
end;
implementation
uses
nld,
symsym,
jvmdef;
function tjvmloadnode.is_addr_param_load: boolean;
begin
result:=
inherited and
not jvmimplicitpointertype(tparavarsym(symtableentry).vardef);
end;
begin
cloadnode:=tjvmloadnode;
end.

24
compiler/jvm/njvmmem.pas
View File

@ -42,7 +42,7 @@ implementation
cutils,verbose,
symdef,defutil,
aasmdata,pass_2,
cgutils,hlcgobj;
cgutils,hlcgobj,hlcgcpu;
{*****************************************************************************
TJVMVECNODE
@ -65,7 +65,9 @@ implementation
location_reset_ref(location,LOC_CREFERENCE,newsize,left.location.reference.alignment)
else
location_reset_ref(location,LOC_REFERENCE,newsize,left.location.reference.alignment);
hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
{ don't use left.resultdef, because it may be an open or regular array,
and then asking for the size doesn't make any sense }
hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,java_jlobject,java_jlobject,true);
location.reference.base:=left.location.register;
secondpass(right);
{ simplify index location if necessary, since array references support
@ -74,6 +76,22 @@ implementation
(right.location.reference.arrayreftype<>art_none) then
hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,true);
{ adjust index if necessary }
if not is_special_array(left.resultdef) and
(tarraydef(left.resultdef).lowrange<>0) and
(right.location.loc<>LOC_CONSTANT) then
begin
thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
thlcgjvm(hlcg).a_op_const_stack(current_asmdata.CurrAsmList,OP_SUB,right.resultdef,tarraydef(left.resultdef).lowrange);
if right.location.loc<>LOC_REGISTER then
begin
location_reset(right.location,LOC_REGISTER,def_cgsize(right.resultdef));
right.location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,right.resultdef);
end;
thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,right.resultdef,right.location.register);
end;
{ create array reference }
case right.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
@ -90,7 +108,7 @@ implementation
LOC_CONSTANT:
begin
location.reference.arrayreftype:=art_indexconst;
location.reference.indexoffset:=right.location.value;
location.reference.indexoffset:=right.location.value-tarraydef(left.resultdef).lowrange;
end
else
internalerror(2011012002);

57
compiler/jvm/tgcpu.pas
View File

@ -31,6 +31,7 @@ unit tgcpu;
uses
globtype,
aasmdata,
cgutils,
symtype,tgobj;
type
@ -39,19 +40,57 @@ unit tgcpu;
ttgjvm = class(ttgobj)
protected
function getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
function alloctemp(list: TAsmList; size, alignment: longint; temptype: ttemptype; def: tdef): longint; override;
public
procedure setfirsttemp(l : longint); override;
procedure getlocal(list: TAsmList; size: longint; alignment: shortint; def: tdef; var ref: treference); override;
procedure gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference); override;
end;
implementation
uses
verbose;
verbose,
cgbase,
symconst,defutil,
hlcgobj,hlcgcpu,
symdef;
{ ttgjvm }
function ttgjvm.getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
var
eledef: tdef;
ndim: longint;
begin
result:=false;
case def.typ of
arraydef:
begin
if not is_dynamic_array(def) then
begin
{ allocate an array of the right size }
gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
ndim:=0;
eledef:=def;
repeat
thlcgjvm(hlcg).a_load_const_stack(list,s32inttype,tarraydef(eledef).elecount,R_INTREGISTER);
eledef:=tarraydef(eledef).elementdef;
inc(ndim);
until (eledef.typ<>arraydef) or
is_dynamic_array(eledef);
eledef:=tarraydef(def).elementdef;
thlcgjvm(hlcg).g_newarray(list,def,ndim);
thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
result:=true;
end;
end;
end;
end;
function ttgjvm.alloctemp(list: TAsmList; size, alignment: longint; temptype: ttemptype; def: tdef): longint;
begin
{ the JVM only supports 1 slot (= 4 bytes in FPC) and 2 slot (= 8 bytes in
@ -67,12 +106,28 @@ unit tgcpu;
result:=inherited alloctemp(list, size shr 2, 1, temptype, nil);
end;
procedure ttgjvm.setfirsttemp(l: longint);
begin
firsttemp:=l;
lasttemp:=l;
end;
procedure ttgjvm.getlocal(list: TAsmList; size: longint; alignment: shortint; def: tdef; var ref: treference);
begin
if not getifspecialtemp(list,def,size,tt_persistent,ref) then
inherited;
end;
procedure ttgjvm.gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference);
begin
if not getifspecialtemp(list,def,forcesize,temptype,ref) then
inherited;
end;
begin
tgobjclass:=ttgjvm;
end.

35
compiler/jvmdef.pas
View File

@ -57,6 +57,10 @@ interface
function jvmarrtype(def: tdef; out primitivetype: boolean): string;
function jvmarrtype_setlength(def: tdef): char;
{ returns whether a def is emulated using an implicit pointer type on the
JVM target (e.g., records, regular arrays, ...) }
function jvmimplicitpointertype(def: tdef): boolean;
implementation
uses
@ -171,7 +175,6 @@ implementation
arraydef :
begin
if is_array_of_const(def) or
is_open_array(def) or
is_packed_array(def) then
result:=false
else
@ -281,8 +284,15 @@ implementation
internalerror(2011012206);
end;
primitivetype:=true;
end
else if (result[1]='L') then
begin
{ in case of a class reference, strip the leading 'L' and the
trailing ';' }
setlength(result,length(result)-1);
delete(result,1,1);
end;
{ in other cases, use the actual reference type }
{ for arrays, use the actual reference type }
end;
@ -299,6 +309,27 @@ implementation
result:='A';
end;
function jvmimplicitpointertype(def: tdef): boolean;
begin
case def.typ of
arraydef:
result:=(tarraydef(def).highrange>=tarraydef(def).lowrange) or
is_open_array(def) or
is_array_of_const(def) or
is_array_constructor(def);
recorddef:
result:=true;
objectdef:
result:=is_object(def);
setdef:
result:=not is_smallset(def);
stringdef :
result:=tstringdef(def).stringtype in [st_shortstring,st_longstring];
else
result:=false;
end;
end;
{******************************************************************
jvm type validity checking

4
compiler/ncgcal.pas
View File

@ -130,7 +130,7 @@ implementation
begin
if not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
internalerror(200304235);
cg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,left.location.reference,tempcgpara);
hlcg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,left.resultdef,tempcgpara.def,left.location.reference,tempcgpara);
end;
@ -174,7 +174,7 @@ implementation
if (parasym.varspez=vs_out) and
is_managed_type(left.resultdef) then
begin
location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false,sizeof(pint));
hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,left.location,href,false,sizeof(pint));
if is_open_array(resultdef) then
begin
if third=nil then

8
compiler/ncgld.pas
View File

@ -603,7 +603,7 @@ implementation
not is_constnode(right) then
begin
hlcg.location_force_mem(current_asmdata.CurrAsmList,right.location,right.resultdef);
location_get_data_ref(current_asmdata.CurrAsmList,right.location,href,false,sizeof(pint));
hlcg.location_get_data_ref(current_asmdata.CurrAsmList,right.resultdef,right.location,href,false,sizeof(pint));
hlcg.g_incrrefcount(current_asmdata.CurrAsmList,right.resultdef,href);
end;
if codegenerror then
@ -615,7 +615,7 @@ implementation
{ decrement destination reference counter }
if is_managed_type(left.resultdef) then
begin
location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false,sizeof(pint));
hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,left.location,href,false,sizeof(pint));
hlcg.g_decrrefcount(current_asmdata.CurrAsmList,left.resultdef,href);
end;
if codegenerror then
@ -628,7 +628,7 @@ implementation
{ decrement destination reference counter }
if is_managed_type(left.resultdef) then
begin
location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false,sizeof(pint));
hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,left.location,href,false,sizeof(pint));
hlcg.g_decrrefcount(current_asmdata.CurrAsmList,left.resultdef,href);
end;
if codegenerror then
@ -650,7 +650,7 @@ implementation
(right.nodetype<>stringconstn) then
begin
hlcg.location_force_mem(current_asmdata.CurrAsmList,right.location,right.resultdef);
location_get_data_ref(current_asmdata.CurrAsmList,right.location,href,false,sizeof(pint));
hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,right.location,href,false,sizeof(pint));
hlcg.g_incrrefcount(current_asmdata.CurrAsmList,right.resultdef,href);
end;

40
compiler/ncgutil.pas
View File

@ -79,9 +79,6 @@ interface
procedure register_maybe_adjust_setbase(list: TAsmList; var l: tlocation; setbase: aint);
{ Retrieve the location of the data pointed to in location l, when the location is
a register it is expected to contain the address of the data }
procedure location_get_data_ref(list:TAsmList;const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);
function has_alias_name(pd:tprocdef;const s:string):boolean;
procedure alloc_proc_symbol(pd: tprocdef);
@ -1208,33 +1205,6 @@ implementation
end;
procedure location_get_data_ref(list:TAsmList;const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);
begin
case l.loc of
LOC_REGISTER,
LOC_CREGISTER :
begin
if not loadref then
internalerror(200410231);
reference_reset_base(ref,l.register,0,alignment);
end;
LOC_REFERENCE,
LOC_CREFERENCE :
begin
if loadref then
begin
reference_reset_base(ref,cg.getaddressregister(list),0,alignment);
cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,l.reference,ref.base);
end
else
ref:=l.reference;
end;
else
internalerror(200309181);
end;
end;
{****************************************************************************
Init/Finalize Code
****************************************************************************}
@ -1254,7 +1224,7 @@ implementation
(paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
begin
{ we have no idea about the alignment at the caller side }
location_get_data_ref(list,tparavarsym(p).initialloc,href,true,1);
hlcg.location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,1);
if is_open_array(tparavarsym(p).vardef) or
is_array_of_const(tparavarsym(p).vardef) then
begin
@ -1605,7 +1575,7 @@ implementation
if not((tparavarsym(p).vardef.typ=variantdef) and
paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
begin
location_get_data_ref(list,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
hlcg.location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
if is_open_array(tparavarsym(p).vardef) then
begin
{ open arrays do not contain correct element count in their rtti,
@ -1617,7 +1587,7 @@ implementation
cg.g_array_rtti_helper(list,eldef,href,hsym.initialloc,'FPC_ADDREF_ARRAY');
end
else
cg.g_incrrefcount(list,tparavarsym(p).vardef,href);
cg.g_incrrefcount(list,tparavarsym(p).vardef,href);
end;
end;
vs_out :
@ -1697,7 +1667,7 @@ implementation
if (tparavarsym(p).varspez=vs_value) then
begin
include(current_procinfo.flags,pi_needs_implicit_finally);
location_get_data_ref(list,tparavarsym(p).localloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
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));
@ -1718,7 +1688,7 @@ implementation
{ cdecl functions don't have a high pointer so it is not possible to generate
a local copy }
if not(current_procinfo.procdef.proccalloption in cdecl_pocalls) then
cg.g_releasevaluepara_openarray(list,tparavarsym(p).localloc);
hlcg.g_releasevaluepara_openarray(list,tarraydef(tparavarsym(p).vardef),tparavarsym(p).localloc);
end;
end;

13
compiler/nld.pas
View File

@ -50,7 +50,7 @@ interface
procedure buildderefimpl;override;
procedure derefimpl;override;
procedure set_mp(p:tnode);
function is_addr_param_load:boolean;
function is_addr_param_load:boolean;virtual;
function dogetcopy : tnode;override;
function pass_1 : tnode;override;
function pass_typecheck:tnode;override;
@ -149,7 +149,7 @@ interface
implementation
uses
cutils,verbose,globtype,globals,systems,
cutils,verbose,globtype,globals,systems,constexp,
symnot,
defutil,defcmp,
htypechk,pass_1,procinfo,paramgr,
@ -550,10 +550,11 @@ implementation
{ remove property flag to avoid errors, see comments for }
{ tf_winlikewidestring assignments below }
exclude(left.flags,nf_isproperty);
hp:=ccallparanode.create(caddrnode.create_internal
(crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),nil));
result := ccallnode.createintern('fpc_dynarray_clear',hp);
{ generate a setlength node so it can be intercepted by
target-specific code }
result:=cinlinenode.create(in_setlength_x,false,
ccallparanode.create(genintconstnode(0),
ccallparanode.create(left,nil)));
left:=nil;
exit;
end;

2
compiler/paramgr.pas
View File

@ -56,7 +56,7 @@ unit paramgr;
}
function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;virtual;abstract;
{ return the size of a push }
function push_size(varspez:tvarspez;def : tdef;calloption : tproccalloption) : longint;
function push_size(varspez:tvarspez;def : tdef;calloption : tproccalloption) : longint;virtual;
{# Returns a structure giving the information on
the storage of the parameter (which must be
an integer parameter). This is only used when calling

4
compiler/tgobj.pas
View File

@ -86,7 +86,7 @@ unit tgobj;
the forcesize parameter is so that it can be used for defs that
don't have an inherent size (e.g., array of const) }
procedure gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference);
procedure gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference); virtual;
procedure gettemp(list: TAsmList; size, alignment : longint;temptype:ttemptype;out ref : treference);
procedure gettemptyped(list: TAsmList; def:tdef;temptype:ttemptype;out ref : treference);
procedure ungettemp(list: TAsmList; const ref : treference);
@ -109,7 +109,7 @@ unit tgobj;
{ Allocate space for a local }
procedure getlocal(list: TAsmList; size : longint;def:tdef;var ref : treference);
procedure getlocal(list: TAsmList; size : longint; alignment : shortint; def:tdef;var ref : treference);
procedure getlocal(list: TAsmList; size : longint; alignment : shortint; def:tdef;var ref : treference); virtual;
procedure UnGetLocal(list: TAsmList; const ref : treference);
end;
ttgobjclass = class of ttgobj;

11
rtl/java/jdynarrh.inc
View File

@ -50,6 +50,17 @@ function fpc_setlength_dynarr_jfloat(aorg, anew: TJFloatArray; deepcopy: boolean
function fpc_setlength_dynarr_jdouble(aorg, anew: TJDoubleArray; deepcopy: boolean): TJDoubleArray;
function fpc_setlength_dynarr_jobject(aorg, anew: TJObjectArray; deepcopy: boolean; docopy : boolean = true): TJObjectArray;
{ array copying helpers }
procedure fpc_copy_jbyte_array(src, dst: TJByteArray);
procedure fpc_copy_jshort_array(src, dst: TJShortArray);
procedure fpc_copy_jint_array(src, dst: TJIntArray);
procedure fpc_copy_jlong_array(src, dst: TJLongArray);
procedure fpc_copy_jchar_array(src, dst: TJCharArray);
procedure fpc_copy_jfloat_array(src, dst: TJFloatArray);
procedure fpc_copy_jdouble_array(src, dst: TJDoubleArray);
procedure fpc_copy_jobject_array(src, dst: TJObjectArray);
{ multi-dimendional setlength routine: all intermediate dimensions are arrays
of arrays, so that's the same for all array kinds. Only the type of the final
dimension matters.

32
rtl/java/system.pp
View File

@ -128,7 +128,7 @@ function min(a,b : longint) : longint;
{ copying helpers }
{ also for booleans }
procedure copy_jbyte_array(src, dst: TJByteArray);
procedure fpc_copy_jbyte_array(src, dst: TJByteArray);
var
i: longint;
begin
@ -137,7 +137,7 @@ procedure copy_jbyte_array(src, dst: TJByteArray);
end;
procedure copy_jshort_array(src, dst: TJShortArray);
procedure fpc_copy_jshort_array(src, dst: TJShortArray);
var
i: longint;
begin
@ -146,7 +146,7 @@ procedure copy_jshort_array(src, dst: TJShortArray);
end;
procedure copy_jint_array(src, dst: TJIntArray);
procedure fpc_copy_jint_array(src, dst: TJIntArray);
var
i: longint;
begin
@ -155,7 +155,7 @@ procedure copy_jint_array(src, dst: TJIntArray);
end;
procedure copy_jlong_array(src, dst: TJLongArray);
procedure fpc_copy_jlong_array(src, dst: TJLongArray);
var
i: longint;
begin
@ -164,7 +164,7 @@ procedure copy_jlong_array(src, dst: TJLongArray);
end;
procedure copy_jchar_array(src, dst: TJCharArray);
procedure fpc_copy_jchar_array(src, dst: TJCharArray);
var
i: longint;
begin
@ -173,7 +173,7 @@ procedure copy_jchar_array(src, dst: TJCharArray);
end;
procedure copy_jfloat_array(src, dst: TJFloatArray);
procedure fpc_copy_jfloat_array(src, dst: TJFloatArray);
var
i: longint;
begin
@ -182,7 +182,7 @@ procedure copy_jfloat_array(src, dst: TJFloatArray);
end;
procedure copy_jdouble_array(src, dst: TJDoubleArray);
procedure fpc_copy_jdouble_array(src, dst: TJDoubleArray);
var
i: longint;
begin
@ -191,7 +191,7 @@ procedure copy_jdouble_array(src, dst: TJDoubleArray);
end;
procedure copy_jobject_array(src, dst: TJObjectArray);
procedure fpc_copy_jobject_array(src, dst: TJObjectArray);
var
i: longint;
begin
@ -207,7 +207,7 @@ function fpc_setlength_dynarr_jbyte(aorg, anew: TJByteArray; deepcopy: boolean):
if deepcopy or
(length(aorg)<>length(anew)) then
begin
copy_jbyte_array(aorg,anew);
fpc_copy_jbyte_array(aorg,anew);
result:=anew
end
else
@ -220,7 +220,7 @@ function fpc_setlength_dynarr_jshort(aorg, anew: TJShortArray; deepcopy: boolean
if deepcopy or
(length(aorg)<>length(anew)) then
begin
copy_jshort_array(aorg,anew);
fpc_copy_jshort_array(aorg,anew);
result:=anew
end
else
@ -233,7 +233,7 @@ function fpc_setlength_dynarr_jint(aorg, anew: TJIntArray; deepcopy: boolean): T
if deepcopy or
(length(aorg)<>length(anew)) then
begin
copy_jint_array(aorg,anew);
fpc_copy_jint_array(aorg,anew);
result:=anew
end
else
@ -246,7 +246,7 @@ function fpc_setlength_dynarr_jlong(aorg, anew: TJLongArray; deepcopy: boolean):
if deepcopy or
(length(aorg)<>length(anew)) then
begin
copy_jlong_array(aorg,anew);
fpc_copy_jlong_array(aorg,anew);
result:=anew
end
else
@ -259,7 +259,7 @@ function fpc_setlength_dynarr_jchar(aorg, anew: TJCharArray; deepcopy: boolean):
if deepcopy or
(length(aorg)<>length(anew)) then
begin
copy_jchar_array(aorg,anew);
fpc_copy_jchar_array(aorg,anew);
result:=anew
end
else
@ -272,7 +272,7 @@ function fpc_setlength_dynarr_jfloat(aorg, anew: TJFloatArray; deepcopy: boolean
if deepcopy or
(length(aorg)<>length(anew)) then
begin
copy_jfloat_array(aorg,anew);
fpc_copy_jfloat_array(aorg,anew);
result:=anew
end
else
@ -285,7 +285,7 @@ function fpc_setlength_dynarr_jdouble(aorg, anew: TJDoubleArray; deepcopy: boole
if deepcopy or
(length(aorg)<>length(anew)) then
begin
copy_jdouble_array(aorg,anew);
fpc_copy_jdouble_array(aorg,anew);
result:=anew
end
else
@ -299,7 +299,7 @@ function fpc_setlength_dynarr_jobject(aorg, anew: TJObjectArray; deepcopy: boole
(length(aorg)<>length(anew)) then
begin
if docopy then
copy_jobject_array(aorg,anew);
fpc_copy_jobject_array(aorg,anew);
result:=anew
end
else