mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 09:39:32 +01:00
478 lines
19 KiB
ObjectPascal
478 lines
19 KiB
ObjectPascal
{
|
|
Copyright (c) 2011 by Jonas Maebe
|
|
|
|
Generate JVM byetcode for in memory related nodes
|
|
|
|
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 njvmmem;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
globtype,
|
|
cgbase,cpubase,
|
|
node,nmem,ncgmem,ncgnstmm;
|
|
|
|
type
|
|
tjvmaddrnode = class(tcgaddrnode)
|
|
protected
|
|
function isrefparaload: boolean;
|
|
function isarrayele0load: boolean;
|
|
function isdererence: boolean;
|
|
public
|
|
function pass_typecheck: tnode; override;
|
|
procedure pass_generate_code; override;
|
|
end;
|
|
|
|
tjvmderefnode = class(tcgderefnode)
|
|
function pass_typecheck: tnode; override;
|
|
procedure pass_generate_code; override;
|
|
end;
|
|
|
|
tjvmloadvmtaddrnode = class(tcgloadvmtaddrnode)
|
|
procedure pass_generate_code; override;
|
|
end;
|
|
|
|
tjvmvecnode = class(tcgvecnode)
|
|
function pass_1: tnode; override;
|
|
procedure pass_generate_code;override;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
systems,globals,procinfo,
|
|
cutils,verbose,constexp,
|
|
aasmbase,
|
|
symconst,symtype,symtable,symsym,symdef,defutil,jvmdef,
|
|
htypechk,paramgr,
|
|
nadd,ncal,ncnv,ncon,nld,nutils,
|
|
pass_1,njvmcon,
|
|
aasmdata,aasmcpu,pass_2,
|
|
cgutils,hlcgobj,hlcgcpu;
|
|
|
|
{*****************************************************************************
|
|
TJVMDEREFNODE
|
|
*****************************************************************************}
|
|
|
|
function tjvmderefnode.pass_typecheck: tnode;
|
|
begin
|
|
result:=inherited pass_typecheck;
|
|
if assigned(result) then
|
|
exit;
|
|
{ don't allow dereferencing untyped pointers, because how this has to
|
|
be done depends on whether it's a pointer to an implicit pointer type
|
|
or not }
|
|
if is_voidpointer(left.resultdef) then
|
|
CGMessage(parser_e_illegal_expression);
|
|
end;
|
|
|
|
|
|
procedure tjvmderefnode.pass_generate_code;
|
|
var
|
|
implicitptr: boolean;
|
|
begin
|
|
secondpass(left);
|
|
implicitptr:=jvmimplicitpointertype(resultdef);
|
|
if implicitptr then
|
|
begin
|
|
{ this is basically a typecast: the left node is a regular
|
|
'pointer', and we typecast it to an implicit pointer }
|
|
location_copy(location,left.location);
|
|
{ these implicit pointer types (records, sets, shortstrings, ...)
|
|
cannot be located in registers on native targets (since
|
|
they're not pointers there) -> force into memory to avoid
|
|
confusing the compiler; this can happen when typecasting a
|
|
Java class type into a pshortstring and then dereferencing etc
|
|
}
|
|
if location.loc in [LOC_REGISTER,LOC_CREGISTER] then
|
|
hlcg.location_force_mem(current_asmdata.CurrAsmList,location,left.resultdef);
|
|
end
|
|
else
|
|
begin
|
|
{ these are always arrays (used internally for pointers to var
|
|
parameters stored in nestedfpstructs, and by programmers for any
|
|
kind of pointers) }
|
|
hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
|
|
location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),4);
|
|
reference_reset_base(location.reference,left.location.register,0,4);
|
|
location.reference.arrayreftype:=art_indexconst;
|
|
if (left.nodetype<>addrn) and
|
|
not(resultdef.typ in [orddef,floatdef]) and
|
|
not is_voidpointer(resultdef) and
|
|
((resultdef.typ<>objectdef) or
|
|
(find_real_class_definition(tobjectdef(resultdef),false)<>java_jlobject)) then
|
|
location.reference.checkcast:=true;
|
|
end
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
TJVMADDRNODE
|
|
*****************************************************************************}
|
|
|
|
function tjvmaddrnode.isrefparaload: boolean;
|
|
begin
|
|
result:=
|
|
(left.nodetype=loadn) and
|
|
(tloadnode(left).symtableentry.typ=paravarsym) and
|
|
paramanager.push_copyout_param(tparavarsym(tloadnode(left).symtableentry).varspez,
|
|
left.resultdef,
|
|
tabstractprocdef(tloadnode(left).symtableentry.owner.defowner).proccalloption);
|
|
end;
|
|
|
|
|
|
function tjvmaddrnode.isarrayele0load: boolean;
|
|
begin
|
|
result:=
|
|
(left.nodetype=vecn) and
|
|
(tvecnode(left).left.resultdef.typ=arraydef) and
|
|
(tvecnode(left).right.nodetype=ordconstn) and
|
|
(tordconstnode(tvecnode(left).right).value=tarraydef(tvecnode(left).left.resultdef).lowrange);
|
|
end;
|
|
|
|
|
|
function tjvmaddrnode.isdererence: boolean;
|
|
var
|
|
target: tnode;
|
|
begin
|
|
target:=actualtargetnode(@left)^;
|
|
result:=
|
|
(left.nodetype=derefn);
|
|
end;
|
|
|
|
|
|
function tjvmaddrnode.pass_typecheck: tnode;
|
|
var
|
|
fsym: tsym;
|
|
begin
|
|
result:=nil;
|
|
typecheckpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
make_not_regable(left,[ra_addr_regable,ra_addr_taken]);
|
|
|
|
{ in TP/Delphi, @procvar = contents of procvar and @@procvar =
|
|
address of procvar. In case of a procedure of object, this works
|
|
by letting the first addrnode typecast the procvar into a tmethod
|
|
record followed by subscripting its "code" field (= first field),
|
|
and if there's a second addrnode then it takes the address of
|
|
this code field (which is hence also the address of the procvar).
|
|
|
|
In Java, such ugly hacks don't work -> replace first addrnode
|
|
with getting procvar.method.code, and second addrnode with
|
|
the class for procedure of object}
|
|
if not(nf_internal in flags) and
|
|
((m_tp_procvar in current_settings.modeswitches) or
|
|
(m_mac_procvar in current_settings.modeswitches)) and
|
|
(((left.nodetype=addrn) and
|
|
(taddrnode(left).left.resultdef.typ=procvardef)) or
|
|
(left.resultdef.typ=procvardef)) then
|
|
begin
|
|
if (left.nodetype=addrn) and
|
|
(taddrnode(left).left.resultdef.typ=procvardef) then
|
|
begin
|
|
{ double address -> pointer that is the address of the
|
|
procvardef (don't allow for non-object procvars, as they
|
|
aren't implicitpointerdefs) }
|
|
if not jvmimplicitpointertype(taddrnode(left).left.resultdef) then
|
|
CGMessage(parser_e_illegal_expression)
|
|
else
|
|
begin
|
|
{ an internal address node will observe "normal" address
|
|
operator semantics (= take the actual address!) }
|
|
result:=caddrnode.create_internal(taddrnode(left).left);
|
|
result:=ctypeconvnode.create_explicit(result,tprocvardef(taddrnode(left).left.resultdef).classdef);
|
|
taddrnode(left).left:=nil;
|
|
end;
|
|
end
|
|
else if left.resultdef.typ=procvardef then
|
|
begin
|
|
if not tprocvardef(left.resultdef).is_addressonly then
|
|
begin
|
|
{ the "code" field from the procvar }
|
|
result:=caddrnode.create_internal(left);
|
|
result:=ctypeconvnode.create_explicit(result,tprocvardef(left.resultdef).classdef);
|
|
{ procvarclass.method }
|
|
fsym:=search_struct_member(tprocvardef(left.resultdef).classdef,'METHOD');
|
|
if not assigned(fsym) or
|
|
(fsym.typ<>fieldvarsym) then
|
|
internalerror(2011072501);
|
|
result:=csubscriptnode.create(fsym,result);
|
|
{ procvarclass.method.code }
|
|
fsym:=search_struct_member(trecorddef(tfieldvarsym(fsym).vardef),'CODE');
|
|
if not assigned(fsym) or
|
|
(fsym.typ<>fieldvarsym) then
|
|
internalerror(2011072502);
|
|
result:=csubscriptnode.create(fsym,result);
|
|
left:=nil
|
|
end
|
|
else
|
|
{ convert contents to plain pointer }
|
|
begin
|
|
result:=ctypeconvnode.create_explicit(left,java_jlobject);
|
|
include(result.flags,nf_load_procvar);
|
|
left:=nil;
|
|
end;
|
|
end
|
|
else
|
|
internalerror(2011072506);
|
|
end
|
|
else if (left.resultdef.typ=procdef) then
|
|
begin
|
|
result:=inherited;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
if not jvmimplicitpointertype(left.resultdef) then
|
|
begin
|
|
{ allow taking the address of a copy-out parameter (it's an
|
|
array reference), of the first element of an array and of a
|
|
pointer derefence }
|
|
if not isrefparaload and
|
|
not isarrayele0load and
|
|
not isdererence then
|
|
begin
|
|
CGMessage(parser_e_illegal_expression);
|
|
exit
|
|
end;
|
|
end;
|
|
result:=inherited;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tjvmaddrnode.pass_generate_code;
|
|
var
|
|
implicitptr: boolean;
|
|
begin
|
|
secondpass(left);
|
|
implicitptr:=jvmimplicitpointertype(left.resultdef);
|
|
if implicitptr then
|
|
{ this is basically a typecast: the left node is an implicit
|
|
pointer, and we typecast it to a regular 'pointer'
|
|
(java.lang.Object) }
|
|
location_copy(location,left.location)
|
|
else
|
|
begin
|
|
{ these are always arrays (used internally for pointers to var
|
|
parameters stored in nestedfpstructs) -> get base pointer to
|
|
array }
|
|
if (left.location.loc<>LOC_REFERENCE) or
|
|
(left.location.reference.arrayreftype<>art_indexconst) or
|
|
(left.location.reference.base=NR_NO) or
|
|
(left.location.reference.indexoffset<>0) or
|
|
assigned(left.location.reference.symbol) then
|
|
internalerror(2011060701);
|
|
location_reset(location,LOC_REGISTER,OS_ADDR);
|
|
location.register:=left.location.reference.base;
|
|
end;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
TJVMLOADVMTADDRNODE
|
|
*****************************************************************************}
|
|
|
|
procedure tjvmloadvmtaddrnode.pass_generate_code;
|
|
begin
|
|
current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_ldc,current_asmdata.RefAsmSymbol(
|
|
tabstractrecorddef(tclassrefdef(resultdef).pointeddef).jvm_full_typename(true))));
|
|
thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
|
|
location_reset(location,LOC_REGISTER,OS_ADDR);
|
|
location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef);
|
|
thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TJVMVECNODE
|
|
*****************************************************************************}
|
|
|
|
function tjvmvecnode.pass_1: tnode;
|
|
var
|
|
psym: tsym;
|
|
stringclass: tdef;
|
|
begin
|
|
if (left.resultdef.typ=stringdef) then
|
|
begin
|
|
case tstringdef(left.resultdef).stringtype of
|
|
st_ansistring:
|
|
stringclass:=java_ansistring;
|
|
st_unicodestring,
|
|
st_widestring:
|
|
stringclass:=java_jlstring;
|
|
st_shortstring:
|
|
begin
|
|
stringclass:=java_shortstring;
|
|
left:=caddrnode.create_internal(left);
|
|
{ avoid useless typecheck when casting to shortstringclass }
|
|
include(left.flags,nf_typedaddr);
|
|
end
|
|
else
|
|
internalerror(2011052407);
|
|
end;
|
|
psym:=search_struct_member(tabstractrecorddef(stringclass),'CHARAT');
|
|
if not assigned(psym) or
|
|
(psym.typ<>procsym) then
|
|
internalerror(2011031501);
|
|
{ Pascal strings are 1-based, Java strings 0-based }
|
|
result:=ccallnode.create(ccallparanode.create(
|
|
caddnode.create(subn,right,genintconstnode(1)),nil),tprocsym(psym),
|
|
psym.owner,ctypeconvnode.create_explicit(left,stringclass),[]);
|
|
left:=nil;
|
|
right:=nil;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
{ keep indices that are enum constants that way, rather than
|
|
transforming them into a load of the class instance that
|
|
represents this constant (since we then would have to extract
|
|
the int constant value again at run time anyway) }
|
|
if right.nodetype=ordconstn then
|
|
tjvmordconstnode(right).enumconstok:=true;
|
|
result:=inherited;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tjvmvecnode.pass_generate_code;
|
|
var
|
|
otl,ofl: tasmlabel;
|
|
psym: tsym;
|
|
newsize: tcgsize;
|
|
isjump: boolean;
|
|
begin
|
|
if left.resultdef.typ=stringdef then
|
|
internalerror(2011052702);
|
|
|
|
{ This routine is not used for Strings, as they are a class type and
|
|
you have to use charAt() there to load a character (and you cannot
|
|
change characters; you have to create a new string in that case)
|
|
|
|
As far as arrays are concerned: we have to create a trefererence
|
|
with arrayreftype in [art_indexreg,art_indexref], and ref.base =
|
|
pointer to the array (i.e., left.location.register) }
|
|
secondpass(left);
|
|
newsize:=def_cgsize(resultdef);
|
|
if left.location.loc=LOC_CREFERENCE then
|
|
location_reset_ref(location,LOC_CREFERENCE,newsize,left.location.reference.alignment)
|
|
else
|
|
location_reset_ref(location,LOC_REFERENCE,newsize,left.location.reference.alignment);
|
|
{ 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;
|
|
isjump:=(right.expectloc=LOC_JUMP);
|
|
if isjump then
|
|
begin
|
|
otl:=current_procinfo.CurrTrueLabel;
|
|
current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
|
|
ofl:=current_procinfo.CurrFalseLabel;
|
|
current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
|
|
end;
|
|
secondpass(right);
|
|
|
|
{ simplify index location if necessary, since array references support
|
|
an index in memory, but not an another array index }
|
|
if isjump or
|
|
((right.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) and
|
|
(right.location.reference.arrayreftype<>art_none)) then
|
|
hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,true);
|
|
|
|
if isjump then
|
|
begin
|
|
current_procinfo.CurrTrueLabel:=otl;
|
|
current_procinfo.CurrFalseLabel:=ofl;
|
|
end
|
|
else if (right.location.loc = LOC_JUMP) then
|
|
internalerror(2011090501);
|
|
{ replace enum class instance with the corresponding integer value }
|
|
if (right.resultdef.typ=enumdef) then
|
|
begin
|
|
if (right.location.loc<>LOC_CONSTANT) then
|
|
begin
|
|
psym:=search_struct_member(tenumdef(right.resultdef).getbasedef.classdef,'FPCORDINAL');
|
|
if not assigned(psym) or
|
|
(psym.typ<>procsym) or
|
|
(tprocsym(psym).ProcdefList.count<>1) then
|
|
internalerror(2011062607);
|
|
thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
|
|
hlcg.a_call_name(current_asmdata.CurrAsmList,tprocdef(tprocsym(psym).procdeflist[0]),tprocdef(tprocsym(psym).procdeflist[0]).mangledname,nil,false);
|
|
{ call replaces self parameter with longint result -> no stack
|
|
height change }
|
|
location_reset(right.location,LOC_REGISTER,OS_S32);
|
|
right.location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,s32inttype);
|
|
thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,s32inttype,right.location.register);
|
|
end;
|
|
{ always force to integer location, because enums are handled as
|
|
object instances (since that's what they are in Java) }
|
|
right.resultdef:=s32inttype;
|
|
right.location.size:=OS_S32;
|
|
end;
|
|
|
|
{ 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
|
|
location.reference.arrayreftype:=art_indexreg;
|
|
location.reference.index:=right.location.register;
|
|
end;
|
|
LOC_REFERENCE,LOC_CREFERENCE:
|
|
begin
|
|
location.reference.arrayreftype:=art_indexref;
|
|
location.reference.indexbase:=right.location.reference.base;
|
|
location.reference.indexsymbol:=right.location.reference.symbol;
|
|
location.reference.indexoffset:=right.location.reference.offset;
|
|
end;
|
|
LOC_CONSTANT:
|
|
begin
|
|
location.reference.arrayreftype:=art_indexconst;
|
|
location.reference.indexoffset:=right.location.value-tarraydef(left.resultdef).lowrange;
|
|
end
|
|
else
|
|
internalerror(2011012002);
|
|
end;
|
|
end;
|
|
|
|
|
|
begin
|
|
cderefnode:=tjvmderefnode;
|
|
caddrnode:=tjvmaddrnode;
|
|
cvecnode:=tjvmvecnode;
|
|
cloadvmtaddrnode:=tjvmloadvmtaddrnode;
|
|
end.
|