1 { 2 Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe 3 Member of the Free Pascal development team 4 5 This unit implements the jvm high level code generator 6 7 This program is free software; you can redistribute it and/or modify 8 it under the terms of the GNU General Public License as published by 9 the Free Software Foundation; either version 2 of the License, or 10 (at your option) any later version. 11 12 This program is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with this program; if not, write to the Free Software 19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 20 21 **************************************************************************** 22 } 23 unit hlcgcpu; 24 25 {$i fpcdefs.inc} 26 27 interface 28 29 uses 30 globtype, 31 aasmbase,aasmdata, 32 symbase,symconst,symtype,symdef,symsym, 33 node, 34 cpubase, hlcgobj, cgbase, cgutils, parabase; 35 36 type 37 38 { thlcgjvm } 39 40 thlcgjvm = class(thlcgobj) 41 private 42 fevalstackheight, 43 fmaxevalstackheight: longint; 44 public 45 constructor create; 46 47 procedure incstack(list : TAsmList;slots: longint); 48 procedure decstack(list : TAsmList;slots: longint); 49 def2regtypnull50 class function def2regtyp(def: tdef): tregistertype; override; 51 52 procedure a_load_const_cgpara(list : TAsmList;tosize : tdef;a : tcgint;const cgpara : TCGPara);override; 53 a_call_namenull54 function a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara;override; a_call_name_inheritednull55 function a_call_name_inherited(list : TAsmList;pd : tprocdef;const s : TSymStr; const paras: array of pcgpara): tcgpara;override; a_call_regnull56 function a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister; const paras: array of pcgpara): tcgpara; override; 57 58 procedure a_load_const_reg(list : TAsmList;tosize : tdef;a : tcgint;register : tregister);override; 59 procedure a_load_const_ref(list : TAsmList;tosize : tdef;a : tcgint;const ref : treference);override; 60 procedure a_load_reg_ref(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);override; 61 procedure a_load_reg_reg(list : TAsmList;fromsize, tosize : tdef;reg1,reg2 : tregister);override; 62 procedure a_load_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);override; 63 procedure a_load_ref_ref(list : TAsmList;fromsize, tosize : tdef;const sref : treference;const dref : treference);override; 64 procedure a_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);override; 65 66 procedure a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; reg: TRegister); override; 67 procedure a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister); override; 68 procedure a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; const ref: TReference); override; 69 70 procedure a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); override; 71 procedure a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); override; 72 procedure a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); override; 73 procedure a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); override; 74 procedure a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation); override; 75 76 procedure a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; const ref: treference; l: tasmlabel); override; 77 procedure a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel); override; 78 procedure a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel); override; 79 procedure a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel); override; 80 procedure a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); override; 81 82 procedure a_jmp_always(list : TAsmList;l: tasmlabel); override; 83 84 procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override; 85 procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);override; 86 87 procedure a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference); override; 88 procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); override; 89 procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); override; 90 procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); override; 91 92 procedure g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean); override; 93 procedure g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean); override; 94 95 procedure gen_load_return_value(list:TAsmList);override; 96 procedure record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList); override; 97 98 procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override; 99 procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); override; 100 procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override; 101 procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override; 102 103 procedure g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); override; 104 procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation); override; 105 106 procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);override; 107 procedure maybe_change_load_node_reg(list: TAsmList; var n: tnode; reload: boolean); override; 108 procedure g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); override; 109 procedure g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); override; 110 111 procedure gen_initialize_code(list: TAsmList); override; 112 113 procedure gen_entry_code(list: TAsmList); override; 114 procedure gen_exit_code(list: TAsmList); override; 115 116 { unimplemented/unnecessary routines } 117 procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; srcsize, dstsize: tdef; src, dst: tregister); override; 118 procedure a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle); override; 119 procedure a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle); override; 120 procedure a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle); override; 121 procedure a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle); override; 122 procedure a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle); override; 123 procedure a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle); override; 124 procedure a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle); override; 125 procedure g_stackpointer_alloc(list: TAsmList; size: longint); override; 126 procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint); override; 127 procedure g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint); override; 128 procedure g_local_unwind(list: TAsmList; l: TAsmLabel); override; 129 130 { JVM-specific routines } 131 132 procedure a_load_stack_reg(list : TAsmList;size: tdef;reg: tregister); 133 { extra_slots are the slots that are used by the reference, and that 134 will be removed by the store operation } 135 procedure a_load_stack_ref(list : TAsmList;size: tdef;const ref: treference;extra_slots: longint); 136 procedure a_load_reg_stack(list : TAsmList;size: tdef;reg: tregister); 137 { extra_slots are the slots that are used by the reference, and that 138 will be removed by the load operation } 139 procedure a_load_ref_stack(list : TAsmList;size: tdef;const ref: treference;extra_slots: longint); 140 procedure a_load_const_stack(list : TAsmList;size: tdef;a :tcgint; typ: TRegisterType); 141 142 procedure a_load_stack_loc(list : TAsmList;size: tdef;const loc: tlocation); 143 procedure a_load_loc_stack(list : TAsmList;size: tdef;const loc: tlocation); 144 145 procedure a_loadfpu_const_stack(list : TAsmList;size: tdef;a :double); 146 147 procedure a_op_stack(list : TAsmList;op: topcg; size: tdef; trunc32: boolean); 148 procedure a_op_const_stack(list : TAsmList;op: topcg; size: tdef;a : tcgint); 149 procedure a_op_reg_stack(list : TAsmList;op: topcg; size: tdef;reg: tregister); 150 procedure a_op_ref_stack(list : TAsmList;op: topcg; size: tdef;const ref: treference); 151 procedure a_op_loc_stack(list : TAsmList;op: topcg; size: tdef;const loc: tlocation); 152 153 procedure g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation); override; 154 155 { assumes that initdim dimensions have already been pushed on the 156 evaluation stack, and creates a new array of type arrdef with these 157 dimensions } 158 procedure g_newarray(list : TAsmList; arrdef: tdef; initdim: longint); 159 { gets the length of the array whose reference is stored in arrloc, 160 and puts it on the evaluation stack } 161 procedure g_getarraylen(list : TAsmList; const arrloc: tlocation); 162 163 { this routine expects that all values are already massaged into the 164 required form (sign bits xor'ed for gt/lt comparisons for OS_32/OS_64, 165 see http://stackoverflow.com/questions/4068973/c-performing-signed-comparison-in-unsigned-variables-without-casting ) } 166 procedure a_cmp_stack_label(list : TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel); 167 { these 2 routines perform the massaging expected by the previous one } 168 procedure maybe_adjust_cmp_stackval(list : TAsmlist; size: tdef; cmp_op: topcmp); maybe_adjust_cmp_constvalnull169 function maybe_adjust_cmp_constval(size: tdef; cmp_op: topcmp; a: tcgint): tcgint; 170 { truncate/sign extend after performing operations on values < 32 bit 171 that may have overflowed outside the range } 172 procedure maybe_adjust_op_result(list: TAsmList; op: TOpCg; size: tdef); 173 174 { performs sign/zero extension as required } 175 procedure resize_stack_int_val(list: TAsmList;fromsize,tosize: tdef; formemstore: boolean); 176 177 { 8/16 bit unsigned parameters and return values must be sign-extended on 178 the producer side, because the JVM does not support unsigned variants; 179 then they have to be zero-extended again on the consumer side } 180 procedure maybe_resize_stack_para_val(list: TAsmList; retdef: tdef; callside: boolean); 181 182 { adjust the stack height after a call based on the specified number of 183 slots used for parameters and the provided resultdef } 184 procedure g_adjust_stack_after_call(list: TAsmList; pd: tabstractprocdef; paraheight: longint; forceresdef: tdef); 185 186 property maxevalstackheight: longint read fmaxevalstackheight; 187 188 procedure gen_initialize_fields_code(list:TAsmList); 189 190 procedure gen_typecheck(list: TAsmList; checkop: tasmop; checkdef: tdef); 191 protected 192 procedure a_load_const_stack_intern(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType; legalize_const: boolean); 193 get_enum_init_val_refnull194 function get_enum_init_val_ref(def: tdef; out ref: treference): boolean; 195 196 procedure allocate_implicit_structs_for_st_with_base_ref(list: TAsmList; st: tsymtable; const ref: treference; allocvartyp: tsymtyp); 197 procedure allocate_enum_with_base_ref(list: TAsmList; vs: tabstractvarsym; const initref: treference; destbaseref: treference); 198 procedure allocate_implicit_struct_with_base_ref(list: TAsmList; vs: tabstractvarsym; ref: treference); 199 procedure gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara); override; 200 201 procedure g_copyvalueparas(p: TObject; arg: pointer); override; 202 203 procedure inittempvariables(list:TAsmList);override; 204 g_call_system_proc_internnull205 function g_call_system_proc_intern(list: TAsmList; pd: tprocdef; const paras: array of pcgpara; forceresdef: tdef): tcgpara; override; 206 207 { in case of an array, the array base address and index have to be 208 put on the evaluation stack before the stored value; similarly, for 209 fields the self pointer has to be loaded first. Also checks whether 210 the reference is valid. If dup is true, the necessary values are stored 211 twice. Returns how many stack slots have been consumed, disregarding 212 the "dup". } prepare_stack_for_refnull213 function prepare_stack_for_ref(list: TAsmList; const ref: treference; dup: boolean): longint; 214 { return the load/store opcode to load/store from/to ref; if the result 215 has to be and'ed after a load to get the final value, that constant 216 is returned in finishandval (otherwise that value is set to -1) } loadstoreopcrefnull217 function loadstoreopcref(def: tdef; isload: boolean; const ref: treference; out finishandval: tcgint): tasmop; 218 { return the load/store opcode to load/store from/to reg; if the result 219 has to be and'ed after a load to get the final value, that constant 220 is returned in finishandval (otherwise that value is set to -1) } loadstoreopcnull221 function loadstoreopc(def: tdef; isload, isarray: boolean; out finishandval: tcgint): tasmop; 222 procedure resizestackfpuval(list: TAsmList; fromsize, tosize: tcgsize); 223 { in case of an OS_32 OP_DIV, we have to use an OS_S64 OP_IDIV because the 224 JVM does not support unsigned divisions } 225 procedure maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean); 226 { common implementation of a_call_* } a_call_name_internnull227 function a_call_name_intern(list : TAsmList;pd : tprocdef;const s : TSymStr; forceresdef: tdef; inheritedcall: boolean): tcgpara; 228 229 { concatcopy helpers } 230 procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference); 231 procedure concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference); 232 procedure concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference); 233 procedure concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference); 234 235 end; 236 237 procedure create_hlcodegen; 238 239 240 const 241 opcmp2if: array[topcmp] of tasmop = (A_None, 242 a_ifeq,a_ifgt,a_iflt,a_ifge,a_ifle, 243 a_ifne,a_ifle,a_iflt,a_ifge,a_ifgt); 244 245 implementation 246 247 uses 248 verbose,cutils,globals,fmodule,constexp, 249 defutil, 250 aasmtai,aasmcpu, 251 symtable,symcpu,jvmdef, 252 procinfo,cpuinfo,cgcpu,tgobj; 253 254 const 255 TOpCG2IAsmOp : array[topcg] of TAsmOp=( { not = xor -1 } 256 A_None,A_None,a_iadd,a_iand,A_none,a_idiv,a_imul,a_imul,a_ineg,A_None,a_ior,a_ishr,a_ishl,a_iushr,a_isub,a_ixor,A_None,A_None 257 ); 258 TOpCG2LAsmOp : array[topcg] of TAsmOp=( { not = xor -1 } 259 A_None,A_None,a_ladd,a_land,A_none,a_ldiv,a_lmul,a_lmul,a_lneg,A_None,a_lor,a_lshr,a_lshl,a_lushr,a_lsub,a_lxor,A_None,A_None 260 ); 261 262 constructor thlcgjvm.create; 263 begin 264 fevalstackheight:=0; 265 fmaxevalstackheight:=0; 266 end; 267 268 procedure thlcgjvm.incstack(list: TasmList;slots: longint); 269 begin 270 if slots=0 then 271 exit; 272 inc(fevalstackheight,slots); 273 if (fevalstackheight>fmaxevalstackheight) then 274 fmaxevalstackheight:=fevalstackheight; 275 if cs_asm_regalloc in current_settings.globalswitches then 276 list.concat(tai_comment.Create(strpnew(' allocated '+tostr(slots)+', stack height = '+tostr(fevalstackheight)))); 277 end; 278 279 procedure thlcgjvm.decstack(list: TAsmList;slots: longint); 280 begin 281 if slots=0 then 282 exit; 283 dec(fevalstackheight,slots); 284 if (fevalstackheight<0) and 285 not(cs_no_regalloc in current_settings.globalswitches) then 286 internalerror(2010120501); 287 if cs_asm_regalloc in current_settings.globalswitches then 288 list.concat(tai_comment.Create(strpnew(' freed '+tostr(slots)+', stack height = '+tostr(fevalstackheight)))); 289 end; 290 thlcgjvm.def2regtypnull291 class function thlcgjvm.def2regtyp(def: tdef): tregistertype; 292 begin 293 case def.typ of 294 { records (including files) and enums are implemented via classes } 295 recorddef, 296 filedef, 297 enumdef, 298 setdef: 299 result:=R_ADDRESSREGISTER; 300 { shortstrings are implemented via classes } 301 else if is_shortstring(def) or 302 { voiddef can only be typecasted into (implicit) pointers } 303 is_void(def) then 304 result:=R_ADDRESSREGISTER 305 else 306 result:=inherited; 307 end; 308 end; 309 310 procedure thlcgjvm.a_load_const_cgpara(list: TAsmList; tosize: tdef; a: tcgint; const cgpara: TCGPara); 311 begin 312 tosize:=get_para_push_size(tosize); 313 if tosize=s8inttype then 314 a:=shortint(a) 315 else if tosize=s16inttype then 316 a:=smallint(a); 317 inherited a_load_const_cgpara(list, tosize, a, cgpara); 318 end; 319 thlcgjvm.a_call_namenull320 function thlcgjvm.a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara; 321 begin 322 result:=a_call_name_intern(list,pd,s,forceresdef,false); 323 end; 324 thlcgjvm.a_call_name_inheritednull325 function thlcgjvm.a_call_name_inherited(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara): tcgpara; 326 begin 327 result:=a_call_name_intern(list,pd,s,nil,true); 328 end; 329 330 thlcgjvm.a_call_regnull331 function thlcgjvm.a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister; const paras: array of pcgpara): tcgpara; 332 begin 333 internalerror(2012042824); 334 result.init; 335 end; 336 337 338 procedure thlcgjvm.a_load_const_stack_intern(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType; legalize_const: boolean); 339 begin 340 if legalize_const and 341 (typ=R_INTREGISTER) and 342 (size.typ=orddef) then 343 begin 344 { uses specific byte/short array store instructions, and the Dalvik 345 VM does not like it if we store values outside the range } 346 case torddef(size).ordtype of 347 u8bit: 348 a:=shortint(a); 349 u16bit: 350 a:=smallint(a); 351 end; 352 end; 353 a_load_const_stack(list,size,a,typ); 354 end; 355 356 357 procedure thlcgjvm.a_load_const_stack(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType); 358 const 359 int2opc: array[-1..5] of tasmop = (a_iconst_m1,a_iconst_0,a_iconst_1, 360 a_iconst_2,a_iconst_3,a_iconst_4,a_iconst_5); 361 begin 362 case typ of 363 R_INTREGISTER: 364 begin 365 case def_cgsize(size) of 366 OS_8,OS_16,OS_32, 367 OS_S8,OS_S16,OS_S32: 368 begin 369 { convert cardinals to longints } 370 a:=longint(a); 371 if (a>=-1) and 372 (a<=5) then 373 list.concat(taicpu.op_none(int2opc[a])) 374 else if (a>=low(shortint)) and 375 (a<=high(shortint)) then 376 list.concat(taicpu.op_const(a_bipush,a)) 377 else if (a>=low(smallint)) and 378 (a<=high(smallint)) then 379 list.concat(taicpu.op_const(a_sipush,a)) 380 else 381 list.concat(taicpu.op_const(a_ldc,a)); 382 { for android verifier } 383 if (size.typ=orddef) and 384 (torddef(size).ordtype=uwidechar) then 385 list.concat(taicpu.op_none(a_i2c)); 386 end; 387 OS_64,OS_S64: 388 begin 389 case a of 390 0: 391 list.concat(taicpu.op_none(a_lconst_0)); 392 1: 393 list.concat(taicpu.op_none(a_lconst_1)); 394 else 395 list.concat(taicpu.op_const(a_ldc2_w,a)); 396 end; 397 incstack(list,1); 398 end; 399 else 400 internalerror(2010110702); 401 end; 402 end; 403 R_ADDRESSREGISTER: 404 begin 405 if a<>0 then 406 internalerror(2010110701); 407 list.concat(taicpu.op_none(a_aconst_null)); 408 end; 409 else 410 internalerror(2010110703); 411 end; 412 incstack(list,1); 413 end; 414 415 procedure thlcgjvm.a_load_stack_loc(list: TAsmList; size: tdef; const loc: tlocation); 416 begin 417 case loc.loc of 418 LOC_REGISTER,LOC_CREGISTER, 419 LOC_FPUREGISTER,LOC_CFPUREGISTER: 420 a_load_stack_reg(list,size,loc.register); 421 LOC_REFERENCE: 422 a_load_stack_ref(list,size,loc.reference,prepare_stack_for_ref(list,loc.reference,false)); 423 else 424 internalerror(2011020501); 425 end; 426 end; 427 428 procedure thlcgjvm.a_load_loc_stack(list: TAsmList;size: tdef;const loc: tlocation); 429 begin 430 case loc.loc of 431 LOC_REGISTER,LOC_CREGISTER, 432 LOC_FPUREGISTER,LOC_CFPUREGISTER: 433 a_load_reg_stack(list,size,loc.register); 434 LOC_REFERENCE,LOC_CREFERENCE: 435 a_load_ref_stack(list,size,loc.reference,prepare_stack_for_ref(list,loc.reference,false)); 436 LOC_CONSTANT: 437 a_load_const_stack(list,size,loc.value,def2regtyp(size)); 438 else 439 internalerror(2011010401); 440 end; 441 end; 442 443 procedure thlcgjvm.a_loadfpu_const_stack(list: TAsmList; size: tdef; a: double); 444 begin 445 case tfloatdef(size).floattype of 446 s32real: 447 begin 448 if a=0.0 then 449 list.concat(taicpu.op_none(a_fconst_0)) 450 else if a=1.0 then 451 list.concat(taicpu.op_none(a_fconst_1)) 452 else if a=2.0 then 453 list.concat(taicpu.op_none(a_fconst_2)) 454 else 455 list.concat(taicpu.op_single(a_ldc,a)); 456 incstack(list,1); 457 end; 458 s64real: 459 begin 460 if a=0.0 then 461 list.concat(taicpu.op_none(a_dconst_0)) 462 else if a=1.0 then 463 list.concat(taicpu.op_none(a_dconst_1)) 464 else 465 list.concat(taicpu.op_double(a_ldc2_w,a)); 466 incstack(list,2); 467 end 468 else 469 internalerror(2011010501); 470 end; 471 end; 472 473 procedure thlcgjvm.a_op_stack(list: TAsmList; op: topcg; size: tdef; trunc32: boolean); 474 var 475 cgsize: tcgsize; 476 begin 477 if not trunc32 then 478 cgsize:=def_cgsize(size) 479 else 480 begin 481 resize_stack_int_val(list,u32inttype,s64inttype,false); 482 cgsize:=OS_S64; 483 end; 484 case cgsize of 485 OS_8,OS_S8, 486 OS_16,OS_S16, 487 OS_32,OS_S32: 488 begin 489 { not = xor 1 for boolean, xor -1 for the rest} 490 if op=OP_NOT then 491 begin 492 if not is_pasbool(size) then 493 a_load_const_stack(list,s32inttype,high(cardinal),R_INTREGISTER) 494 else 495 a_load_const_stack(list,size,1,R_INTREGISTER); 496 op:=OP_XOR; 497 end; 498 if TOpCG2IAsmOp[op]=A_None then 499 internalerror(2010120532); 500 list.concat(taicpu.op_none(TOpCG2IAsmOp[op])); 501 maybe_adjust_op_result(list,op,size); 502 if op<>OP_NEG then 503 decstack(list,1); 504 end; 505 OS_64,OS_S64: 506 begin 507 { unsigned 64 bit division must be done via a helper } 508 if op=OP_DIV then 509 internalerror(2010120530); 510 { not = xor 1 for boolean, xor -1 for the rest} 511 if op=OP_NOT then 512 begin 513 if not is_pasbool(size) then 514 a_load_const_stack(list,s64inttype,-1,R_INTREGISTER) 515 else 516 a_load_const_stack(list,s64inttype,1,R_INTREGISTER); 517 op:=OP_XOR; 518 end; 519 if TOpCG2LAsmOp[op]=A_None then 520 internalerror(2010120533); 521 list.concat(taicpu.op_none(TOpCG2LAsmOp[op])); 522 case op of 523 OP_NOT, 524 OP_NEG: 525 ; 526 { the second argument here is an int rather than a long } 527 OP_SHL,OP_SHR,OP_SAR: 528 decstack(list,1); 529 else 530 decstack(list,2); 531 end; 532 end; 533 else 534 internalerror(2010120531); 535 end; 536 if trunc32 then 537 begin 538 list.concat(taicpu.op_none(a_l2i)); 539 decstack(list,1); 540 end; 541 end; 542 543 procedure thlcgjvm.a_op_const_stack(list: TAsmList;op: topcg;size: tdef;a: tcgint); 544 var 545 trunc32: boolean; 546 begin 547 maybepreparedivu32(list,op,size,trunc32); 548 case op of 549 OP_NEG,OP_NOT: 550 internalerror(2011010801); 551 OP_SHL,OP_SHR,OP_SAR: 552 { the second argument here is an int rather than a long } 553 a_load_const_stack(list,s32inttype,a,R_INTREGISTER); 554 else 555 a_load_const_stack(list,size,a,R_INTREGISTER); 556 end; 557 a_op_stack(list,op,size,trunc32); 558 end; 559 560 procedure thlcgjvm.a_op_reg_stack(list: TAsmList; op: topcg; size: tdef; reg: tregister); 561 var 562 trunc32: boolean; 563 begin 564 maybepreparedivu32(list,op,size,trunc32); 565 case op of 566 OP_SHL,OP_SHR,OP_SAR: 567 if not is_64bitint(size) then 568 a_load_reg_stack(list,size,reg) 569 else 570 begin 571 { the second argument here is an int rather than a long } 572 if getsubreg(reg)=R_SUBQ then 573 internalerror(2011010802); 574 a_load_reg_stack(list,s32inttype,reg) 575 end 576 else 577 a_load_reg_stack(list,size,reg); 578 end; 579 a_op_stack(list,op,size,trunc32); 580 end; 581 582 procedure thlcgjvm.a_op_ref_stack(list: TAsmList; op: topcg; size: tdef; const ref: treference); 583 var 584 trunc32: boolean; 585 begin 586 { ref must not be the stack top, because that may indicate an error 587 (it means that we will perform an operation of the stack top onto 588 itself, so that means the two values have been loaded manually prior 589 to calling this routine, instead of letting this routine load one of 590 them; if something like that is needed, call a_op_stack() directly) } 591 if ref.base=NR_EVAL_STACK_BASE then 592 internalerror(2010121102); 593 maybepreparedivu32(list,op,size,trunc32); 594 case op of 595 OP_SHL,OP_SHR,OP_SAR: 596 begin 597 if not is_64bitint(size) then 598 a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)) 599 else 600 a_load_ref_stack(list,s32inttype,ref,prepare_stack_for_ref(list,ref,false)); 601 end; 602 else 603 a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)); 604 end; 605 a_op_stack(list,op,size,trunc32); 606 end; 607 608 procedure thlcgjvm.a_op_loc_stack(list: TAsmList; op: topcg; size: tdef; const loc: tlocation); 609 begin 610 case loc.loc of 611 LOC_REGISTER,LOC_CREGISTER: 612 a_op_reg_stack(list,op,size,loc.register); 613 LOC_REFERENCE,LOC_CREFERENCE: 614 a_op_ref_stack(list,op,size,loc.reference); 615 LOC_CONSTANT: 616 a_op_const_stack(list,op,size,loc.value); 617 else 618 internalerror(2011011415) 619 end; 620 end; 621 622 procedure thlcgjvm.g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation); 623 begin 624 case fromloc.loc of 625 LOC_CREFERENCE, 626 LOC_REFERENCE: 627 begin 628 toloc:=fromloc; 629 if (fromloc.reference.base<>NR_NO) and 630 (fromloc.reference.base<>current_procinfo.framepointer) and 631 (fromloc.reference.base<>NR_STACK_POINTER_REG) then 632 g_allocload_reg_reg(list,voidpointertype,fromloc.reference.base,toloc.reference.base,R_ADDRESSREGISTER); 633 case fromloc.reference.arrayreftype of 634 art_indexreg: 635 begin 636 { all array indices in Java are 32 bit ints } 637 g_allocload_reg_reg(list,s32inttype,fromloc.reference.index,toloc.reference.index,R_INTREGISTER); 638 end; 639 art_indexref: 640 begin 641 { base register of the address of the index -> pointer } 642 if (fromloc.reference.indexbase<>NR_NO) and 643 (fromloc.reference.indexbase<>NR_STACK_POINTER_REG) then 644 g_allocload_reg_reg(list,voidpointertype,fromloc.reference.indexbase,toloc.reference.indexbase,R_ADDRESSREGISTER); 645 end; 646 end; 647 end; 648 else 649 inherited; 650 end; 651 end; 652 653 procedure thlcgjvm.g_newarray(list: TAsmList; arrdef: tdef; initdim: longint); 654 var 655 recref, 656 enuminitref: treference; 657 elemdef: tdef; 658 i: longint; 659 mangledname: string; 660 opc: tasmop; 661 primitivetype: boolean; 662 begin 663 elemdef:=arrdef; 664 if initdim>1 then 665 begin 666 { multianewarray typedesc ndim } 667 list.concat(taicpu.op_sym_const(a_multianewarray, 668 current_asmdata.RefAsmSymbol(jvmarrtype(elemdef,primitivetype),AT_METADATA),initdim)); 669 { has to be a multi-dimensional array type } 670 if primitivetype then 671 internalerror(2011012207); 672 end 673 else 674 begin 675 { for primitive types: 676 newarray typedesc 677 for reference types: 678 anewarray typedesc 679 } 680 { get the type of the elements of the array we are creating } 681 elemdef:=tarraydef(arrdef).elementdef; 682 mangledname:=jvmarrtype(elemdef,primitivetype); 683 if primitivetype then 684 opc:=a_newarray 685 else 686 opc:=a_anewarray; 687 list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(mangledname,AT_METADATA))); 688 end; 689 { all dimensions are removed from the stack, an array reference is 690 added } 691 decstack(list,initdim-1); 692 { in case of an array of records, sets or shortstrings, initialise } 693 elemdef:=tarraydef(arrdef).elementdef; 694 for i:=1 to pred(initdim) do 695 elemdef:=tarraydef(elemdef).elementdef; 696 if (elemdef.typ in [recorddef,setdef]) or 697 ((elemdef.typ=enumdef) and 698 get_enum_init_val_ref(elemdef,enuminitref)) or 699 is_shortstring(elemdef) or 700 ((elemdef.typ=procvardef) and 701 not tprocvardef(elemdef).is_addressonly) or 702 is_ansistring(elemdef) or 703 is_wide_or_unicode_string(elemdef) or 704 is_dynamic_array(elemdef) then 705 begin 706 { duplicate array instance } 707 list.concat(taicpu.op_none(a_dup)); 708 incstack(list,1); 709 a_load_const_stack(list,s32inttype,initdim-1,R_INTREGISTER); 710 case elemdef.typ of 711 arraydef: 712 g_call_system_proc(list,'fpc_initialize_array_dynarr',[],nil); 713 recorddef,setdef,procvardef: 714 begin 715 tg.gethltemp(list,elemdef,elemdef.size,tt_persistent,recref); 716 a_load_ref_stack(list,elemdef,recref,prepare_stack_for_ref(list,recref,false)); 717 case elemdef.typ of 718 recorddef: 719 g_call_system_proc(list,'fpc_initialize_array_record',[],nil); 720 setdef: 721 begin 722 if tsetdef(elemdef).elementdef.typ=enumdef then 723 g_call_system_proc(list,'fpc_initialize_array_enumset',[],nil) 724 else 725 g_call_system_proc(list,'fpc_initialize_array_bitset',[],nil) 726 end; 727 procvardef: 728 g_call_system_proc(list,'fpc_initialize_array_procvar',[],nil); 729 end; 730 tg.ungettemp(list,recref); 731 end; 732 enumdef: 733 begin 734 a_load_ref_stack(list,java_jlobject,enuminitref,prepare_stack_for_ref(list,enuminitref,false)); 735 g_call_system_proc(list,'fpc_initialize_array_object',[],nil); 736 end; 737 stringdef: 738 begin 739 case tstringdef(elemdef).stringtype of 740 st_shortstring: 741 begin 742 a_load_const_stack_intern(list,u8inttype,tstringdef(elemdef).len,R_INTREGISTER,true); 743 g_call_system_proc(list,'fpc_initialize_array_shortstring',[],nil); 744 end; 745 st_ansistring: 746 g_call_system_proc(list,'fpc_initialize_array_ansistring',[],nil); 747 st_unicodestring, 748 st_widestring: 749 g_call_system_proc(list,'fpc_initialize_array_unicodestring',[],nil); 750 else 751 internalerror(2011081801); 752 end; 753 end; 754 else 755 internalerror(2011081801); 756 end; 757 end; 758 end; 759 760 procedure thlcgjvm.g_getarraylen(list: TAsmList; const arrloc: tlocation); 761 var 762 nillab,endlab: tasmlabel; 763 begin 764 { inline because we have to use the arraylength opcode, which 765 cannot be represented directly in Pascal. Even though the JVM 766 supports allocated arrays with length=0, we still also have to 767 check for nil pointers because even if FPC always generates 768 allocated empty arrays under all circumstances, external Java 769 code could pass in nil pointers. 770 771 Note that this means that assigned(arr) can be different from 772 length(arr)<>0 for dynamic arrays when targeting the JVM. 773 } 774 current_asmdata.getjumplabel(nillab); 775 current_asmdata.getjumplabel(endlab); 776 777 { if assigned(arr) ... } 778 a_load_loc_stack(list,java_jlobject,arrloc); 779 list.concat(taicpu.op_none(a_dup)); 780 incstack(list,1); 781 list.concat(taicpu.op_sym(a_ifnull,nillab)); 782 decstack(list,1); 783 784 { ... then result:=arraylength(arr) ... } 785 list.concat(taicpu.op_none(a_arraylength)); 786 a_jmp_always(list,endlab); 787 788 { ... else result:=0 } 789 a_label(list,nillab); 790 list.concat(taicpu.op_none(a_pop)); 791 decstack(list,1); 792 list.concat(taicpu.op_none(a_iconst_0)); 793 incstack(list,1); 794 795 a_label(list,endlab); 796 end; 797 798 procedure thlcgjvm.a_cmp_stack_label(list: TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel); 799 const 800 opcmp2icmp: array[topcmp] of tasmop = (A_None, 801 a_if_icmpeq,a_if_icmpgt,a_if_icmplt,a_if_icmpge,a_if_icmple, 802 a_if_icmpne,a_if_icmple,a_if_icmplt,a_if_icmpge,a_if_icmpgt); 803 var 804 cgsize: tcgsize; 805 begin 806 case def2regtyp(size) of 807 R_INTREGISTER: 808 begin 809 cgsize:=def_cgsize(size); 810 case cgsize of 811 OS_S8,OS_8, 812 OS_16,OS_S16, 813 OS_S32,OS_32: 814 begin 815 list.concat(taicpu.op_sym(opcmp2icmp[cmp_op],lab)); 816 decstack(list,2); 817 end; 818 OS_64,OS_S64: 819 begin 820 list.concat(taicpu.op_none(a_lcmp)); 821 decstack(list,3); 822 list.concat(taicpu.op_sym(opcmp2if[cmp_op],lab)); 823 decstack(list,1); 824 end; 825 else 826 internalerror(2010120538); 827 end; 828 end; 829 R_ADDRESSREGISTER: 830 begin 831 case cmp_op of 832 OC_EQ: 833 list.concat(taicpu.op_sym(a_if_acmpeq,lab)); 834 OC_NE: 835 list.concat(taicpu.op_sym(a_if_acmpne,lab)); 836 else 837 internalerror(2010120537); 838 end; 839 decstack(list,2); 840 end; 841 else 842 internalerror(2010120538); 843 end; 844 end; 845 846 procedure thlcgjvm.maybe_adjust_cmp_stackval(list: TAsmlist; size: tdef; cmp_op: topcmp); 847 begin 848 { use cmp_op because eventually that's what indicates the 849 signed/unsigned character of the operation, not the size... } 850 if (cmp_op in [OC_EQ,OC_NE,OC_LT,OC_LTE,OC_GT,OC_GTE]) or 851 (def2regtyp(size)<>R_INTREGISTER) then 852 exit; 853 { http://stackoverflow.com/questions/4068973/c-performing-signed-comparison-in-unsigned-variables-without-casting } 854 case def_cgsize(size) of 855 OS_32,OS_S32: 856 a_op_const_stack(list,OP_XOR,size,cardinal($80000000)); 857 OS_64,OS_S64: 858 a_op_const_stack(list,OP_XOR,size,tcgint($8000000000000000)); 859 end; 860 end; 861 thlcgjvm.maybe_adjust_cmp_constvalnull862 function thlcgjvm.maybe_adjust_cmp_constval(size: tdef; cmp_op: topcmp; a: tcgint): tcgint; 863 begin 864 result:=a; 865 { use cmp_op because eventually that's what indicates the 866 signed/unsigned character of the operation, not the size... } 867 if (cmp_op in [OC_EQ,OC_NE,OC_LT,OC_LTE,OC_GT,OC_GTE]) or 868 (def2regtyp(size)<>R_INTREGISTER) then 869 exit; 870 case def_cgsize(size) of 871 OS_32,OS_S32: 872 result:=a xor cardinal($80000000); 873 OS_64,OS_S64: 874 result:=a xor tcgint($8000000000000000); 875 end; 876 end; 877 878 procedure thlcgjvm.maybe_adjust_op_result(list: TAsmList; op: TOpCg; size: tdef); 879 const 880 overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NOT,OP_NEG]; 881 begin 882 if ((op in overflowops) or 883 (current_settings.cputype=cpu_dalvik)) and 884 (def_cgsize(size) in [OS_8,OS_S8,OS_16,OS_S16]) then 885 resize_stack_int_val(list,s32inttype,size,false); 886 end; 887 888 procedure thlcgjvm.gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara); 889 begin 890 { constructors don't return anything in Java } 891 if pd.proctypeoption=potype_constructor then 892 exit; 893 { must return a value of the correct type on the evaluation stack } 894 case def2regtyp(resdef) of 895 R_INTREGISTER, 896 R_ADDRESSREGISTER: 897 a_load_const_cgpara(list,resdef,0,resloc); 898 R_FPUREGISTER: 899 case tfloatdef(resdef).floattype of 900 s32real: 901 begin 902 list.concat(taicpu.op_none(a_fconst_0)); 903 incstack(list,1); 904 end; 905 s64real: 906 begin 907 list.concat(taicpu.op_none(a_dconst_0)); 908 incstack(list,2); 909 end; 910 else 911 internalerror(2011010302); 912 end 913 else 914 internalerror(2011010301); 915 end; 916 end; 917 918 919 procedure thlcgjvm.g_copyvalueparas(p: TObject; arg: pointer); 920 var 921 list: tasmlist; 922 tmpref: treference; 923 begin 924 { zero-extend < 32 bit primitive types (FPC can zero-extend when calling, 925 but that doesn't help when we're called from Java code or indirectly 926 as a procvar -- exceptions: widechar (Java-specific type) and ordinal 927 types whose upper bound does not set the sign bit } 928 if (tsym(p).typ=paravarsym) and 929 (tparavarsym(p).varspez in [vs_value,vs_const]) and 930 (tparavarsym(p).vardef.typ=orddef) and 931 not is_pasbool(tparavarsym(p).vardef) and 932 not is_widechar(tparavarsym(p).vardef) and 933 (tparavarsym(p).vardef.size<4) and 934 not is_signed(tparavarsym(p).vardef) and 935 (torddef(tparavarsym(p).vardef).high>=(1 shl (tparavarsym(p).vardef.size*8-1))) then 936 begin 937 list:=TAsmList(arg); 938 { store value in new location to keep Android verifier happy } 939 tg.gethltemp(list,tparavarsym(p).vardef,tparavarsym(p).vardef.size,tt_persistent,tmpref); 940 a_load_loc_stack(list,tparavarsym(p).vardef,tparavarsym(p).initialloc); 941 a_op_const_stack(list,OP_AND,tparavarsym(p).vardef,(1 shl (tparavarsym(p).vardef.size*8))-1); 942 a_load_stack_ref(list,tparavarsym(p).vardef,tmpref,prepare_stack_for_ref(list,tmpref,false)); 943 location_reset_ref(tparavarsym(p).localloc,LOC_REFERENCE,def_cgsize(tparavarsym(p).vardef),4,tmpref.volatility); 944 tparavarsym(p).localloc.reference:=tmpref; 945 end; 946 947 inherited g_copyvalueparas(p, arg); 948 end; 949 950 951 procedure thlcgjvm.inittempvariables(list: TAsmList); 952 begin 953 { these are automatically initialised when allocated if necessary } 954 end; 955 956 thlcgjvm.g_call_system_proc_internnull957 function thlcgjvm.g_call_system_proc_intern(list: TAsmList; pd: tprocdef; const paras: array of pcgpara; forceresdef: tdef): tcgpara; 958 begin 959 result:=inherited; 960 pd.init_paraloc_info(callerside); 961 g_adjust_stack_after_call(list,pd,pd.callerargareasize,forceresdef); 962 end; 963 964 thlcgjvm.prepare_stack_for_refnull965 function thlcgjvm.prepare_stack_for_ref(list: TAsmList; const ref: treference; dup: boolean): longint; 966 var 967 href: treference; 968 begin 969 result:=0; 970 { fake location that indicates the value is already on the stack? } 971 if (ref.base=NR_EVAL_STACK_BASE) then 972 exit; 973 if ref.arrayreftype=art_none then 974 begin 975 { non-array accesses cannot have an index reg } 976 if ref.index<>NR_NO then 977 internalerror(2010120509); 978 if (ref.base<>NR_NO) then 979 begin 980 if (ref.base<>NR_STACK_POINTER_REG) then 981 begin 982 { regular field -> load self on the stack } 983 a_load_reg_stack(list,voidpointertype,ref.base); 984 if dup then 985 begin 986 list.concat(taicpu.op_none(a_dup)); 987 incstack(list,1); 988 end; 989 { field name/type encoded in symbol, no index/offset } 990 if not assigned(ref.symbol) or 991 (ref.offset<>0) then 992 internalerror(2010120524); 993 result:=1; 994 end 995 else 996 begin 997 { local variable -> offset encoded in opcode and nothing to 998 do here, except for checking that it's a valid reference } 999 if assigned(ref.symbol) then 1000 internalerror(2010120523); 1001 end; 1002 end 1003 else 1004 begin 1005 { static field -> nothing to do here, except for validity check } 1006 if not assigned(ref.symbol) or 1007 (ref.offset<>0) then 1008 internalerror(2010120525); 1009 end; 1010 end 1011 else 1012 begin 1013 { arrays have implicit dereference -> pointer to array must have been 1014 loaded into base reg } 1015 if (ref.base=NR_NO) or 1016 (ref.base=NR_STACK_POINTER_REG) then 1017 internalerror(2010120511); 1018 if assigned(ref.symbol) then 1019 internalerror(2010120512); 1020 1021 { stack: ... -> ..., arrayref, index } 1022 { load array base address } 1023 a_load_reg_stack(list,voidpointertype,ref.base); 1024 { index can either be in a register, or located in a simple memory 1025 location (since we have to load it anyway) } 1026 case ref.arrayreftype of 1027 art_indexreg: 1028 begin 1029 if ref.index=NR_NO then 1030 internalerror(2010120513); 1031 { all array indices in Java are 32 bit ints } 1032 a_load_reg_stack(list,s32inttype,ref.index); 1033 end; 1034 art_indexref: 1035 begin 1036 cgutils.reference_reset_base(href,ref.indexbase,ref.indexoffset,ref.temppos,4,ref.volatility); 1037 href.symbol:=ref.indexsymbol; 1038 a_load_ref_stack(list,s32inttype,href,prepare_stack_for_ref(list,href,false)); 1039 end; 1040 art_indexconst: 1041 begin 1042 a_load_const_stack(list,s32inttype,ref.indexoffset,R_INTREGISTER); 1043 end; 1044 else 1045 internalerror(2011012001); 1046 end; 1047 { adjustment of the index } 1048 if ref.offset<>0 then 1049 a_op_const_stack(list,OP_ADD,s32inttype,ref.offset); 1050 if dup then 1051 begin 1052 list.concat(taicpu.op_none(a_dup2)); 1053 incstack(list,2); 1054 end; 1055 result:=2; 1056 end; 1057 end; 1058 1059 procedure thlcgjvm.a_load_const_reg(list: TAsmList; tosize: tdef; a: tcgint; register: tregister); 1060 begin 1061 a_load_const_stack(list,tosize,a,def2regtyp(tosize)); 1062 a_load_stack_reg(list,tosize,register); 1063 end; 1064 1065 procedure thlcgjvm.a_load_const_ref(list: TAsmList; tosize: tdef; a: tcgint; const ref: treference); 1066 var 1067 extra_slots: longint; 1068 begin 1069 extra_slots:=prepare_stack_for_ref(list,ref,false); 1070 a_load_const_stack_intern(list,tosize,a,def2regtyp(tosize),(ref.arrayreftype<>art_none) or assigned(ref.symbol)); 1071 a_load_stack_ref(list,tosize,ref,extra_slots); 1072 end; 1073 1074 procedure thlcgjvm.a_load_reg_ref(list: TAsmList; fromsize, tosize: tdef; register: tregister; const ref: treference); 1075 var 1076 extra_slots: longint; 1077 begin 1078 extra_slots:=prepare_stack_for_ref(list,ref,false); 1079 a_load_reg_stack(list,fromsize,register); 1080 if def2regtyp(fromsize)=R_INTREGISTER then 1081 resize_stack_int_val(list,fromsize,tosize,(ref.arrayreftype<>art_none) or assigned(ref.symbol)); 1082 a_load_stack_ref(list,tosize,ref,extra_slots); 1083 end; 1084 1085 procedure thlcgjvm.a_load_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); 1086 begin 1087 a_load_reg_stack(list,fromsize,reg1); 1088 if def2regtyp(fromsize)=R_INTREGISTER then 1089 resize_stack_int_val(list,fromsize,tosize,false); 1090 a_load_stack_reg(list,tosize,reg2); 1091 end; 1092 1093 procedure thlcgjvm.a_load_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; register: tregister); 1094 var 1095 extra_slots: longint; 1096 begin 1097 extra_slots:=prepare_stack_for_ref(list,ref,false); 1098 a_load_ref_stack(list,fromsize,ref,extra_slots); 1099 1100 if def2regtyp(fromsize)=R_INTREGISTER then 1101 resize_stack_int_val(list,fromsize,tosize,false); 1102 a_load_stack_reg(list,tosize,register); 1103 end; 1104 1105 procedure thlcgjvm.a_load_ref_ref(list: TAsmList; fromsize, tosize: tdef; const sref: treference; const dref: treference); 1106 var 1107 extra_sslots, 1108 extra_dslots: longint; 1109 begin 1110 { make sure the destination reference is on top, since in the end the 1111 order has to be "destref, value" -> first create "destref, sourceref" } 1112 extra_dslots:=prepare_stack_for_ref(list,dref,false); 1113 extra_sslots:=prepare_stack_for_ref(list,sref,false); 1114 a_load_ref_stack(list,fromsize,sref,extra_sslots); 1115 if def2regtyp(fromsize)=R_INTREGISTER then 1116 resize_stack_int_val(list,fromsize,tosize,(dref.arrayreftype<>art_none) or assigned(dref.symbol)); 1117 a_load_stack_ref(list,tosize,dref,extra_dslots); 1118 end; 1119 1120 procedure thlcgjvm.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister); 1121 begin 1122 { only allowed for types that are not implicit pointers in Pascal (in 1123 that case, ref contains a pointer to the actual data and we simply 1124 return that pointer) } 1125 if not jvmimplicitpointertype(fromsize) then 1126 internalerror(2010120534); 1127 a_load_ref_reg(list,java_jlobject,java_jlobject,ref,r); 1128 end; 1129 1130 procedure thlcgjvm.a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; reg: TRegister); 1131 begin 1132 a_op_const_reg_reg(list,op,size,a,reg,reg); 1133 end; 1134 1135 procedure thlcgjvm.a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister); 1136 begin 1137 a_load_reg_stack(list,size,src); 1138 a_op_const_stack(list,op,size,a); 1139 a_load_stack_reg(list,size,dst); 1140 end; 1141 1142 procedure thlcgjvm.a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; const ref: TReference); 1143 var 1144 extra_slots: longint; 1145 begin 1146 extra_slots:=prepare_stack_for_ref(list,ref,true); 1147 { TODO, here or in peepholeopt: use iinc when possible } 1148 a_load_ref_stack(list,size,ref,extra_slots); 1149 a_op_const_stack(list,op,size,a); 1150 { for android verifier } 1151 if (def2regtyp(size)=R_INTREGISTER) and 1152 ((ref.arrayreftype<>art_none) or 1153 assigned(ref.symbol)) then 1154 resize_stack_int_val(list,size,size,true); 1155 a_load_stack_ref(list,size,ref,extra_slots); 1156 end; 1157 1158 procedure thlcgjvm.a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); 1159 begin 1160 if not(op in [OP_NOT,OP_NEG]) then 1161 a_load_reg_stack(list,size,reg); 1162 a_op_ref_stack(list,op,size,ref); 1163 a_load_stack_reg(list,size,reg); 1164 end; 1165 1166 procedure thlcgjvm.a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); 1167 begin 1168 if not(op in [OP_NOT,OP_NEG]) then 1169 a_load_reg_stack(list,size,src2); 1170 a_op_reg_stack(list,op,size,src1); 1171 a_load_stack_reg(list,size,dst); 1172 end; 1173 1174 procedure thlcgjvm.a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); 1175 begin 1176 a_op_reg_reg_reg(list,op,size,reg1,reg2,reg2); 1177 end; 1178 1179 procedure thlcgjvm.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister; setflags: boolean; var ovloc: tlocation); 1180 var 1181 tmpreg: tregister; 1182 begin 1183 if not setflags then 1184 begin 1185 inherited; 1186 exit; 1187 end; 1188 tmpreg:=getintregister(list,size); 1189 a_load_const_reg(list,size,a,tmpreg); 1190 a_op_reg_reg_reg_checkoverflow(list,op,size,tmpreg,src,dst,true,ovloc); 1191 end; 1192 1193 procedure thlcgjvm.a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister; setflags: boolean; var ovloc: tlocation); 1194 var 1195 orgsrc1, orgsrc2: tregister; 1196 docheck: boolean; 1197 lab: tasmlabel; 1198 begin 1199 if not setflags then 1200 begin 1201 inherited; 1202 exit; 1203 end; 1204 { anything else cannot overflow } 1205 docheck:=size.size in [4,8]; 1206 if docheck then 1207 begin 1208 orgsrc1:=src1; 1209 orgsrc2:=src2; 1210 if src1=dst then 1211 begin 1212 orgsrc1:=getintregister(list,size); 1213 a_load_reg_reg(list,size,size,src1,orgsrc1); 1214 end; 1215 if src2=dst then 1216 begin 1217 orgsrc2:=getintregister(list,size); 1218 a_load_reg_reg(list,size,size,src2,orgsrc2); 1219 end; 1220 end; 1221 a_op_reg_reg_reg(list,op,size,src1,src2,dst); 1222 if docheck then 1223 begin 1224 { * signed overflow for addition iff 1225 - src1 and src2 are negative and result is positive (excep in case of 1226 subtraction, then sign of src1 has to be inverted) 1227 - src1 and src2 are positive and result is negative 1228 -> Simplified boolean equivalent (in terms of sign bits): 1229 not(src1 xor src2) and (src1 xor dst) 1230 1231 for subtraction, multiplication: invert src1 sign bit 1232 for division: handle separately (div by zero, low(inttype) div -1), 1233 not supported by this code 1234 1235 * unsigned overflow iff carry out, aka dst < src1 or dst < src2 1236 } 1237 location_reset(ovloc,LOC_REGISTER,OS_S32); 1238 { not pasbool8, because then we'd still have to convert the integer to 1239 a boolean via branches for Dalvik} 1240 ovloc.register:=getintregister(list,s32inttype); 1241 if not ((size.typ=pointerdef) or 1242 ((size.typ=orddef) and 1243 (torddef(size).ordtype in [u64bit,u16bit,u32bit,u8bit,uchar, 1244 pasbool1,pasbool8,pasbool16,pasbool32,pasbool64]))) then 1245 begin 1246 a_load_reg_stack(list,size,src1); 1247 if op in [OP_SUB,OP_IMUL] then 1248 a_op_stack(list,OP_NOT,size,false); 1249 a_op_reg_stack(list,OP_XOR,size,src2); 1250 a_op_stack(list,OP_NOT,size,false); 1251 a_load_reg_stack(list,size,src1); 1252 a_op_reg_stack(list,OP_XOR,size,dst); 1253 a_op_stack(list,OP_AND,size,false); 1254 a_op_const_stack(list,OP_SHR,size,(size.size*8)-1); 1255 if size.size=8 then 1256 begin 1257 list.concat(taicpu.op_none(a_l2i)); 1258 decstack(list,1); 1259 end; 1260 end 1261 else 1262 begin 1263 a_load_const_stack(list,s32inttype,0,R_INTREGISTER); 1264 current_asmdata.getjumplabel(lab); 1265 { can be optimized by removing duplicate xor'ing to convert dst from 1266 signed to unsigned quadrant } 1267 a_cmp_reg_reg_label(list,size,OC_B,dst,src1,lab); 1268 a_cmp_reg_reg_label(list,size,OC_B,dst,src2,lab); 1269 a_op_const_stack(list,OP_XOR,s32inttype,1); 1270 a_label(list,lab); 1271 end; 1272 a_load_stack_reg(list,s32inttype,ovloc.register); 1273 end 1274 else 1275 ovloc.loc:=LOC_VOID; 1276 end; 1277 1278 procedure thlcgjvm.a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; const ref: treference; l: tasmlabel); 1279 begin 1280 if ref.base<>NR_EVAL_STACK_BASE then 1281 a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)); 1282 maybe_adjust_cmp_stackval(list,size,cmp_op); 1283 a_load_const_stack(list,size,maybe_adjust_cmp_constval(size,cmp_op,a),def2regtyp(size)); 1284 a_cmp_stack_label(list,size,cmp_op,l); 1285 end; 1286 1287 procedure thlcgjvm.a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel); 1288 begin 1289 a_load_reg_stack(list,size,reg); 1290 maybe_adjust_cmp_stackval(list,size,cmp_op); 1291 a_load_const_stack(list,size,maybe_adjust_cmp_constval(size,cmp_op,a),def2regtyp(size)); 1292 a_cmp_stack_label(list,size,cmp_op,l); 1293 end; 1294 1295 procedure thlcgjvm.a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel); 1296 begin 1297 a_load_reg_stack(list,size,reg); 1298 maybe_adjust_cmp_stackval(list,size,cmp_op); 1299 if ref.base<>NR_EVAL_STACK_BASE then 1300 a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)) 1301 else 1302 list.concat(taicpu.op_none(a_swap)); 1303 maybe_adjust_cmp_stackval(list,size,cmp_op); 1304 a_cmp_stack_label(list,size,cmp_op,l); 1305 end; 1306 1307 procedure thlcgjvm.a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel); 1308 begin 1309 if ref.base<>NR_EVAL_STACK_BASE then 1310 a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)); 1311 maybe_adjust_cmp_stackval(list,size,cmp_op); 1312 a_load_reg_stack(list,size,reg); 1313 maybe_adjust_cmp_stackval(list,size,cmp_op); 1314 a_cmp_stack_label(list,size,cmp_op,l); 1315 end; 1316 1317 procedure thlcgjvm.a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); 1318 begin 1319 a_load_reg_stack(list,size,reg2); 1320 maybe_adjust_cmp_stackval(list,size,cmp_op); 1321 a_load_reg_stack(list,size,reg1); 1322 maybe_adjust_cmp_stackval(list,size,cmp_op); 1323 a_cmp_stack_label(list,size,cmp_op,l); 1324 end; 1325 1326 procedure thlcgjvm.a_jmp_always(list: TAsmList; l: tasmlabel); 1327 begin 1328 list.concat(taicpu.op_sym(a_goto,current_asmdata.RefAsmSymbol(l.name,AT_METADATA))); 1329 end; 1330 1331 procedure thlcgjvm.concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference); 1332 var 1333 procname: string; 1334 eledef: tdef; 1335 ndim: longint; 1336 adddefaultlenparas: boolean; 1337 begin 1338 { load copy helper parameters on the stack } 1339 a_load_ref_stack(list,java_jlobject,source,prepare_stack_for_ref(list,source,false)); 1340 a_load_ref_stack(list,java_jlobject,dest,prepare_stack_for_ref(list,dest,false)); 1341 { call copy helper } 1342 eledef:=tarraydef(size).elementdef; 1343 ndim:=1; 1344 adddefaultlenparas:=true; 1345 case eledef.typ of 1346 orddef: 1347 begin 1348 case torddef(eledef).ordtype of 1349 pasbool1,pasbool8,s8bit,u8bit,bool8bit,uchar, 1350 s16bit,u16bit,bool16bit,pasbool16, 1351 uwidechar, 1352 s32bit,u32bit,bool32bit,pasbool32, 1353 s64bit,u64bit,bool64bit,pasbool64,scurrency: 1354 procname:='FPC_COPY_SHALLOW_ARRAY' 1355 else 1356 internalerror(2011020504); 1357 end; 1358 end; 1359 arraydef: 1360 begin 1361 { call fpc_setlength_dynarr_multidim with deepcopy=true, and extra 1362 parameters } 1363 while (eledef.typ=arraydef) and 1364 not is_dynamic_array(eledef) do 1365 begin 1366 eledef:=tarraydef(eledef).elementdef; 1367 inc(ndim) 1368 end; 1369 if (ndim=1) then 1370 procname:='FPC_COPY_SHALLOW_ARRAY' 1371 else 1372 begin 1373 { deepcopy=true } 1374 a_load_const_stack(list,pasbool1type,1,R_INTREGISTER); 1375 { ndim } 1376 a_load_const_stack(list,s32inttype,ndim,R_INTREGISTER); 1377 { eletype } 1378 a_load_const_stack(list,cwidechartype,ord(jvmarrtype_setlength(eledef)),R_INTREGISTER); 1379 adddefaultlenparas:=false; 1380 procname:='FPC_SETLENGTH_DYNARR_MULTIDIM'; 1381 end; 1382 end; 1383 recorddef: 1384 procname:='FPC_COPY_JRECORD_ARRAY'; 1385 procvardef: 1386 if tprocvardef(eledef).is_addressonly then 1387 procname:='FPC_COPY_SHALLOW_ARRAY' 1388 else 1389 procname:='FPC_COPY_JPROCVAR_ARRAY'; 1390 setdef: 1391 if tsetdef(eledef).elementdef.typ=enumdef then 1392 procname:='FPC_COPY_JENUMSET_ARRAY' 1393 else 1394 procname:='FPC_COPY_JBITSET_ARRAY'; 1395 floatdef: 1396 procname:='FPC_COPY_SHALLOW_ARRAY'; 1397 stringdef: 1398 if is_shortstring(eledef) then 1399 procname:='FPC_COPY_JSHORTSTRING_ARRAY' 1400 else 1401 procname:='FPC_COPY_SHALLOW_ARRAY'; 1402 variantdef: 1403 begin 1404 {$ifndef nounsupported} 1405 procname:='FPC_COPY_SHALLOW_ARRAY'; 1406 {$else} 1407 { todo: make a deep copy via clone... } 1408 internalerror(2011020505); 1409 {$endif} 1410 end; 1411 else 1412 procname:='FPC_COPY_SHALLOW_ARRAY'; 1413 end; 1414 if adddefaultlenparas then 1415 begin 1416 { -1, -1 means "copy entire array" } 1417 a_load_const_stack(list,s32inttype,-1,R_INTREGISTER); 1418 a_load_const_stack(list,s32inttype,-1,R_INTREGISTER); 1419 end; 1420 g_call_system_proc(list,procname,[],nil); 1421 if ndim<>1 then 1422 begin 1423 { pop return value, must be the same as dest } 1424 list.concat(taicpu.op_none(a_pop)); 1425 decstack(list,1); 1426 end; 1427 end; 1428 1429 procedure thlcgjvm.concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference); 1430 var 1431 srsym: tsym; 1432 pd: tprocdef; 1433 begin 1434 { self } 1435 a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false)); 1436 { result } 1437 a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false)); 1438 { call fpcDeepCopy helper } 1439 srsym:=search_struct_member(tabstractrecorddef(size),'FPCDEEPCOPY'); 1440 if not assigned(srsym) or 1441 (srsym.typ<>procsym) then 1442 Message1(cg_f_unknown_compilerproc,size.typename+'.fpcDeepCopy'); 1443 pd:=tprocdef(tprocsym(srsym).procdeflist[0]); 1444 a_call_name(list,pd,pd.mangledname,[],nil,false); 1445 { both parameters are removed, no function result } 1446 decstack(list,2); 1447 end; 1448 1449 1450 procedure thlcgjvm.concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference); 1451 begin 1452 a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false)); 1453 a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false)); 1454 { call set copy helper } 1455 if tsetdef(size).elementdef.typ=enumdef then 1456 g_call_system_proc(list,'fpc_enumset_copy',[],nil) 1457 else 1458 g_call_system_proc(list,'fpc_bitset_copy',[],nil); 1459 end; 1460 1461 1462 procedure thlcgjvm.concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference); 1463 var 1464 srsym: tsym; 1465 pd: tprocdef; 1466 begin 1467 { self } 1468 a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false)); 1469 { result } 1470 a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false)); 1471 { call fpcDeepCopy helper } 1472 srsym:=search_struct_member(java_shortstring,'FPCDEEPCOPY'); 1473 if not assigned(srsym) or 1474 (srsym.typ<>procsym) then 1475 Message1(cg_f_unknown_compilerproc,'ShortstringClass.FpcDeepCopy'); 1476 pd:=tprocdef(tprocsym(srsym).procdeflist[0]); 1477 a_call_name(list,pd,pd.mangledname,[],nil,false); 1478 { both parameters are removed, no function result } 1479 decstack(list,2); 1480 end; 1481 1482 1483 procedure thlcgjvm.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference); 1484 var 1485 handled: boolean; 1486 begin 1487 handled:=false; 1488 case size.typ of 1489 arraydef: 1490 begin 1491 if not is_dynamic_array(size) then 1492 begin 1493 concatcopy_normal_array(list,size,source,dest); 1494 handled:=true; 1495 end; 1496 end; 1497 recorddef: 1498 begin 1499 concatcopy_record(list,size,source,dest); 1500 handled:=true; 1501 end; 1502 setdef: 1503 begin 1504 concatcopy_set(list,size,source,dest); 1505 handled:=true; 1506 end; 1507 stringdef: 1508 begin 1509 if is_shortstring(size) then 1510 begin 1511 concatcopy_shortstring(list,size,source,dest); 1512 handled:=true; 1513 end; 1514 end; 1515 procvardef: 1516 begin 1517 if not tprocvardef(size).is_addressonly then 1518 begin 1519 concatcopy_record(list,tcpuprocvardef(size).classdef,source,dest); 1520 handled:=true; 1521 end; 1522 end; 1523 end; 1524 if not handled then 1525 inherited; 1526 end; 1527 1528 procedure thlcgjvm.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef); 1529 begin 1530 concatcopy_shortstring(list,strdef,source,dest); 1531 end; 1532 1533 procedure thlcgjvm.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference); 1534 var 1535 dstack_slots: longint; 1536 begin 1537 dstack_slots:=prepare_stack_for_ref(list,ref2,false); 1538 a_load_ref_stack(list,fromsize,ref1,prepare_stack_for_ref(list,ref1,false)); 1539 resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize)); 1540 a_load_stack_ref(list,tosize,ref2,dstack_slots); 1541 end; 1542 1543 procedure thlcgjvm.a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); 1544 begin 1545 a_load_ref_stack(list,fromsize,ref,prepare_stack_for_ref(list,ref,false)); 1546 resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize)); 1547 a_load_stack_reg(list,tosize,reg); 1548 end; 1549 1550 procedure thlcgjvm.a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); 1551 var 1552 dstack_slots: longint; 1553 begin 1554 dstack_slots:=prepare_stack_for_ref(list,ref,false); 1555 a_load_reg_stack(list,fromsize,reg); 1556 resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize)); 1557 a_load_stack_ref(list,tosize,ref,dstack_slots); 1558 end; 1559 1560 procedure thlcgjvm.a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); 1561 begin 1562 a_load_reg_stack(list,fromsize,reg1); 1563 resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize)); 1564 a_load_stack_reg(list,tosize,reg2); 1565 end; 1566 1567 procedure thlcgjvm.g_proc_entry(list: TAsmList; localsize: longint; nostackframe: boolean); 1568 begin 1569 { the localsize is based on tg.lasttemp -> already in terms of stack 1570 slots rather than bytes } 1571 list.concat(tai_directive.Create(asd_jlimit,'locals '+tostr(localsize))); 1572 { we insert the unit initialisation code afterwards in the proginit code, 1573 and it uses one stack slot } 1574 if (current_procinfo.procdef.proctypeoption=potype_proginit) then 1575 fmaxevalstackheight:=max(1,fmaxevalstackheight); 1576 list.concat(tai_directive.Create(asd_jlimit,'stack '+tostr(fmaxevalstackheight))); 1577 end; 1578 1579 procedure thlcgjvm.g_proc_exit(list: TAsmList; parasize: longint; nostackframe: boolean); 1580 var 1581 retdef: tdef; 1582 opc: tasmop; 1583 begin 1584 if current_procinfo.procdef.proctypeoption in [potype_constructor,potype_class_constructor] then 1585 retdef:=voidtype 1586 else 1587 retdef:=current_procinfo.procdef.returndef; 1588 case retdef.typ of 1589 orddef: 1590 case torddef(retdef).ordtype of 1591 uvoid: 1592 opc:=a_return; 1593 s64bit, 1594 u64bit, 1595 scurrency: 1596 opc:=a_lreturn; 1597 else 1598 opc:=a_ireturn; 1599 end; 1600 setdef: 1601 opc:=a_areturn; 1602 floatdef: 1603 case tfloatdef(retdef).floattype of 1604 s32real: 1605 opc:=a_freturn; 1606 s64real: 1607 opc:=a_dreturn; 1608 else 1609 internalerror(2011010213); 1610 end; 1611 else 1612 opc:=a_areturn; 1613 end; 1614 list.concat(taicpu.op_none(opc)); 1615 end; 1616 1617 procedure thlcgjvm.gen_load_return_value(list: TAsmList); 1618 begin 1619 { constructors don't return anything in the jvm } 1620 if current_procinfo.procdef.proctypeoption in [potype_constructor,potype_class_constructor] then 1621 exit; 1622 inherited gen_load_return_value(list); 1623 end; 1624 1625 procedure thlcgjvm.record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList); 1626 begin 1627 { add something to the al_procedures list as well, because if all al_* 1628 lists are empty, the assembler writer isn't called } 1629 if not code.empty and 1630 current_asmdata.asmlists[al_procedures].empty then 1631 current_asmdata.asmlists[al_procedures].concat(tai_align.Create(4)); 1632 tcpuprocdef(pd).exprasmlist:=TAsmList.create; 1633 tcpuprocdef(pd).exprasmlist.concatlist(code); 1634 if assigned(data) and 1635 not data.empty then 1636 internalerror(2010122801); 1637 end; 1638 1639 procedure thlcgjvm.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference); 1640 begin 1641 // do nothing 1642 end; 1643 1644 procedure thlcgjvm.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); 1645 var 1646 normaldim: longint; 1647 eleref: treference; 1648 begin 1649 { only in case of initialisation, we have to set all elements to "empty" } 1650 if name<>'fpc_initialize_array' then 1651 exit; 1652 { put array on the stack } 1653 a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false)); 1654 { in case it's an open array whose elements are regular arrays, put the 1655 dimension of the regular arrays on the stack (otherwise pass 0) } 1656 normaldim:=0; 1657 while (t.typ=arraydef) and 1658 not is_dynamic_array(t) do 1659 begin 1660 inc(normaldim); 1661 t:=tarraydef(t).elementdef; 1662 end; 1663 a_load_const_stack(list,s32inttype,normaldim,R_INTREGISTER); 1664 { highloc is invalid, the length is part of the array in Java } 1665 if is_wide_or_unicode_string(t) then 1666 g_call_system_proc(list,'fpc_initialize_array_unicodestring',[],nil) 1667 else if is_ansistring(t) then 1668 g_call_system_proc(list,'fpc_initialize_array_ansistring',[],nil) 1669 else if is_dynamic_array(t) then 1670 g_call_system_proc(list,'fpc_initialize_array_dynarr',[],nil) 1671 else if is_record(t) or 1672 (t.typ=setdef) then 1673 begin 1674 tg.gethltemp(list,t,t.size,tt_persistent,eleref); 1675 a_load_ref_stack(list,t,eleref,prepare_stack_for_ref(list,eleref,false)); 1676 if is_record(t) then 1677 g_call_system_proc(list,'fpc_initialize_array_record',[],nil) 1678 else if tsetdef(t).elementdef.typ=enumdef then 1679 g_call_system_proc(list,'fpc_initialize_array_enumset',[],nil) 1680 else 1681 g_call_system_proc(list,'fpc_initialize_array_bitset',[],nil); 1682 tg.ungettemp(list,eleref); 1683 end 1684 else if (t.typ=enumdef) then 1685 begin 1686 if get_enum_init_val_ref(t,eleref) then 1687 begin 1688 a_load_ref_stack(list,java_jlobject,eleref,prepare_stack_for_ref(list,eleref,false)); 1689 g_call_system_proc(list,'fpc_initialize_array_object',[],nil); 1690 end; 1691 end 1692 else 1693 internalerror(2011031901); 1694 end; 1695 1696 procedure thlcgjvm.g_initialize(list: TAsmList; t: tdef; const ref: treference); 1697 var 1698 dummyloc: tlocation; 1699 sym: tsym; 1700 pd: tprocdef; 1701 begin 1702 if (t.typ=arraydef) and 1703 not is_dynamic_array(t) then 1704 begin 1705 dummyloc.loc:=LOC_INVALID; 1706 g_array_rtti_helper(list,tarraydef(t).elementdef,ref,dummyloc,'fpc_initialize_array') 1707 end 1708 else if is_record(t) then 1709 begin 1710 { call the fpcInitializeRec method } 1711 sym:=tsym(trecorddef(t).symtable.find('FPCINITIALIZEREC')); 1712 if assigned(sym) and 1713 (sym.typ=procsym) then 1714 begin 1715 if tprocsym(sym).procdeflist.Count<>1 then 1716 internalerror(2011071713); 1717 pd:=tprocdef(tprocsym(sym).procdeflist[0]); 1718 end 1719 else 1720 internalerror(2013113008); 1721 a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false)); 1722 a_call_name(list,pd,pd.mangledname,[],nil,false); 1723 { parameter removed, no result } 1724 decstack(list,1); 1725 end 1726 else 1727 a_load_const_ref(list,t,0,ref); 1728 end; 1729 1730 procedure thlcgjvm.g_finalize(list: TAsmList; t: tdef; const ref: treference); 1731 begin 1732 // do nothing 1733 end; 1734 1735 procedure thlcgjvm.g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); 1736 begin 1737 { not possible, need the original operands } 1738 internalerror(2012102101); 1739 end; 1740 1741 procedure thlcgjvm.g_overflowCheck_loc(List: TAsmList; const Loc: TLocation; def: TDef; var ovloc: tlocation); 1742 var 1743 hl : tasmlabel; 1744 begin 1745 if not(cs_check_overflow in current_settings.localswitches) then 1746 exit; 1747 current_asmdata.getjumplabel(hl); 1748 a_cmp_const_loc_label(list,s32inttype,OC_EQ,0,ovloc,hl); 1749 g_call_system_proc(list,'fpc_overflow',[],nil); 1750 a_label(list,hl); 1751 end; 1752 1753 procedure thlcgjvm.location_get_data_ref(list: TAsmList; def: tdef; const l: tlocation; var ref: treference; loadref: boolean; alignment: longint); 1754 var 1755 tmploc: tlocation; 1756 begin 1757 { This routine is a combination of a generalised a_loadaddr_ref_reg() 1758 that also works for addresses in registers (in case loadref is false) 1759 and of a_load_ref_reg (in case loadref is true). It is used for 1760 a) getting the address of managed var/out parameters 1761 b) getting to the actual data of value types that are passed by 1762 reference by the compiler (and then get a local copy at the caller 1763 side). Normally, depending on whether this reference is passed in a 1764 register or reference, we either need a reference with that register 1765 as base or load the address in that reference and use that as a new 1766 base. 1767 1768 Since the JVM cannot take the address of anything, all 1769 "pass-by-reference" value parameters (which are always aggregate types) 1770 are already simply the implicit pointer to the data (since arrays, 1771 records, etc are already internally implicit pointers). This means 1772 that if "loadref" is true, we must simply return this implicit pointer. 1773 If it is false, we are supposed the take the address of this implicit 1774 pointer, which is not possible. 1775 1776 However, managed types are also implicit pointers in Pascal, so in that 1777 case "taking the address" again consists of simply returning the 1778 implicit pointer/current value (in case of a var/out parameter, this 1779 value is stored inside an array). 1780 } 1781 if not loadref then 1782 begin 1783 if not is_managed_type(def) then 1784 internalerror(2011020601); 1785 tmploc:=l; 1786 end 1787 else 1788 begin 1789 if not jvmimplicitpointertype(def) then 1790 begin 1791 { passed by reference in array of single element; l contains the 1792 base address of the array } 1793 location_reset_ref(tmploc,LOC_REFERENCE,OS_ADDR,4,ref.volatility); 1794 cgutils.reference_reset_base(tmploc.reference,getaddressregister(list,java_jlobject),0,tmploc.reference.temppos,4,ref.volatility); 1795 tmploc.reference.arrayreftype:=art_indexconst; 1796 tmploc.reference.indexoffset:=0; 1797 a_load_loc_reg(list,java_jlobject,java_jlobject,l,tmploc.reference.base); 1798 end 1799 else 1800 tmploc:=l; 1801 end; 1802 case tmploc.loc of 1803 LOC_REGISTER, 1804 LOC_CREGISTER : 1805 begin 1806 { the implicit pointer is in a register and has to be in a 1807 reference -> create a reference and put it there } 1808 location_force_mem(list,tmploc,java_jlobject); 1809 ref:=tmploc.reference; 1810 end; 1811 LOC_REFERENCE, 1812 LOC_CREFERENCE : 1813 begin 1814 ref:=tmploc.reference; 1815 end; 1816 else 1817 internalerror(2011020603); 1818 end; 1819 end; 1820 1821 procedure thlcgjvm.maybe_change_load_node_reg(list: TAsmList; var n: tnode; reload: boolean); 1822 begin 1823 { don't do anything, all registers become stack locations anyway } 1824 end; 1825 1826 procedure thlcgjvm.g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); 1827 var 1828 localref: treference; 1829 arrloc: tlocation; 1830 stackslots: longint; 1831 begin 1832 { temporary reference for passing to concatcopy } 1833 tg.gethltemp(list,java_jlobject,java_jlobject.size,tt_persistent,localref); 1834 stackslots:=prepare_stack_for_ref(list,localref,false); 1835 { create the local copy of the array (lenloc is invalid, get length 1836 directly from the array) } 1837 location_reset_ref(arrloc,LOC_REFERENCE,OS_ADDR,sizeof(pint),ref.volatility); 1838 arrloc.reference:=ref; 1839 g_getarraylen(list,arrloc); 1840 g_newarray(list,arrdef,1); 1841 a_load_stack_ref(list,java_jlobject,localref,stackslots); 1842 { copy the source array to the destination } 1843 g_concatcopy(list,arrdef,ref,localref); 1844 { and put the array pointer in the register as expected by the caller } 1845 a_load_ref_reg(list,java_jlobject,java_jlobject,localref,destreg); 1846 end; 1847 1848 procedure thlcgjvm.g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); 1849 begin 1850 // do nothing, long live garbage collection! 1851 end; 1852 1853 procedure thlcgjvm.gen_initialize_code(list: TAsmList); 1854 var 1855 ref: treference; 1856 begin 1857 { create globals with wrapped types such as arrays/records } 1858 case current_procinfo.procdef.proctypeoption of 1859 potype_unitinit: 1860 begin 1861 cgutils.reference_reset_base(ref,NR_NO,0,ctempposinvalid,1,[]); 1862 if assigned(current_module.globalsymtable) then 1863 allocate_implicit_structs_for_st_with_base_ref(list,current_module.globalsymtable,ref,staticvarsym); 1864 allocate_implicit_structs_for_st_with_base_ref(list,current_module.localsymtable,ref,staticvarsym); 1865 end; 1866 potype_class_constructor: 1867 begin 1868 { also initialise local variables, if any } 1869 inherited; 1870 { initialise class fields } 1871 cgutils.reference_reset_base(ref,NR_NO,0,ctempposinvalid,1,[]); 1872 allocate_implicit_structs_for_st_with_base_ref(list,tabstractrecorddef(current_procinfo.procdef.owner.defowner).symtable,ref,staticvarsym); 1873 end 1874 else 1875 inherited 1876 end; 1877 end; 1878 1879 procedure thlcgjvm.gen_entry_code(list: TAsmList); 1880 begin 1881 list.concat(Tai_force_line.Create); 1882 end; 1883 1884 procedure thlcgjvm.gen_exit_code(list: TAsmList); 1885 begin 1886 { nothing } 1887 end; 1888 1889 procedure thlcgjvm.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; srcsize, dstsize: tdef; src, dst: tregister); 1890 begin 1891 internalerror(2012090201); 1892 end; 1893 1894 procedure thlcgjvm.a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle); 1895 begin 1896 internalerror(2012090202); 1897 end; 1898 1899 procedure thlcgjvm.a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle); 1900 begin 1901 internalerror(2012060130); 1902 end; 1903 1904 procedure thlcgjvm.a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle); 1905 begin 1906 internalerror(2012060131); 1907 end; 1908 1909 procedure thlcgjvm.a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle); 1910 begin 1911 internalerror(2012060132); 1912 end; 1913 1914 procedure thlcgjvm.a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle); 1915 begin 1916 internalerror(2012060133); 1917 end; 1918 1919 procedure thlcgjvm.a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle); 1920 begin 1921 internalerror(2012060134); 1922 end; 1923 1924 procedure thlcgjvm.a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle); 1925 begin 1926 internalerror(2012060135); 1927 end; 1928 1929 procedure thlcgjvm.g_stackpointer_alloc(list: TAsmList; size: longint); 1930 begin 1931 internalerror(2012090203); 1932 end; 1933 1934 procedure thlcgjvm.g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint); 1935 begin 1936 internalerror(2012090204); 1937 end; 1938 1939 procedure thlcgjvm.g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint); 1940 begin 1941 internalerror(2012090205); 1942 end; 1943 1944 procedure thlcgjvm.g_local_unwind(list: TAsmList; l: TAsmLabel); 1945 begin 1946 internalerror(2012090206); 1947 end; 1948 1949 procedure thlcgjvm.a_load_stack_reg(list: TAsmList; size: tdef; reg: tregister); 1950 var 1951 opc: tasmop; 1952 finishandval: tcgint; 1953 begin 1954 opc:=loadstoreopc(size,false,false,finishandval); 1955 list.concat(taicpu.op_reg(opc,reg)); 1956 { avoid problems with getting the size of an open array etc } 1957 if jvmimplicitpointertype(size) then 1958 size:=java_jlobject; 1959 decstack(list,1+ord(size.size>4)); 1960 end; 1961 1962 procedure thlcgjvm.a_load_stack_ref(list: TAsmList; size: tdef; const ref: treference; extra_slots: longint); 1963 var 1964 opc: tasmop; 1965 finishandval: tcgint; 1966 begin 1967 { fake location that indicates the value has to remain on the stack } 1968 if ref.base=NR_EVAL_STACK_BASE then 1969 exit; 1970 opc:=loadstoreopcref(size,false,ref,finishandval); 1971 if ref.arrayreftype=art_none then 1972 list.concat(taicpu.op_ref(opc,ref)) 1973 else 1974 list.concat(taicpu.op_none(opc)); 1975 { avoid problems with getting the size of an open array etc } 1976 if jvmimplicitpointertype(size) then 1977 size:=java_jlobject; 1978 decstack(list,1+ord(size.size>4)+extra_slots); 1979 end; 1980 1981 procedure thlcgjvm.a_load_reg_stack(list: TAsmList; size: tdef; reg: tregister); 1982 var 1983 opc: tasmop; 1984 finishandval: tcgint; 1985 begin 1986 opc:=loadstoreopc(size,true,false,finishandval); 1987 list.concat(taicpu.op_reg(opc,reg)); 1988 { avoid problems with getting the size of an open array etc } 1989 if jvmimplicitpointertype(size) then 1990 size:=java_jlobject; 1991 incstack(list,1+ord(size.size>4)); 1992 if finishandval<>-1 then 1993 a_op_const_stack(list,OP_AND,size,finishandval); 1994 end; 1995 1996 procedure thlcgjvm.a_load_ref_stack(list: TAsmList; size: tdef; const ref: treference; extra_slots: longint); 1997 var 1998 opc: tasmop; 1999 finishandval: tcgint; 2000 begin 2001 { fake location that indicates the value is already on the stack? } 2002 if (ref.base=NR_EVAL_STACK_BASE) then 2003 exit; 2004 opc:=loadstoreopcref(size,true,ref,finishandval); 2005 if ref.arrayreftype=art_none then 2006 list.concat(taicpu.op_ref(opc,ref)) 2007 else 2008 list.concat(taicpu.op_none(opc)); 2009 { avoid problems with getting the size of an open array etc } 2010 if jvmimplicitpointertype(size) then 2011 size:=java_jlobject; 2012 incstack(list,1+ord(size.size>4)-extra_slots); 2013 if finishandval<>-1 then 2014 a_op_const_stack(list,OP_AND,size,finishandval); 2015 if ref.checkcast then 2016 gen_typecheck(list,a_checkcast,size); 2017 end; 2018 thlcgjvm.loadstoreopcrefnull2019 function thlcgjvm.loadstoreopcref(def: tdef; isload: boolean; const ref: treference; out finishandval: tcgint): tasmop; 2020 const 2021 { isload static } 2022 getputopc: array[boolean,boolean] of tasmop = 2023 ((a_putfield,a_putstatic), 2024 (a_getfield,a_getstatic)); 2025 begin 2026 if assigned(ref.symbol) then 2027 begin 2028 { -> either a global (static) field, or a regular field. If a regular 2029 field, then ref.base contains the self pointer, otherwise 2030 ref.base=NR_NO. In both cases, the symbol contains all other 2031 information (combined field name and type descriptor) } 2032 result:=getputopc[isload,ref.base=NR_NO]; 2033 finishandval:=-1; 2034 { erase sign extension for byte/smallint loads } 2035 if (def2regtyp(def)=R_INTREGISTER) and 2036 not is_signed(def) and 2037 (def.typ=orddef) and 2038 not is_widechar(def) then 2039 case def.size of 2040 1: if (torddef(def).high>127) then 2041 finishandval:=255; 2042 2: if (torddef(def).high>32767) then 2043 finishandval:=65535; 2044 end; 2045 end 2046 else 2047 result:=loadstoreopc(def,isload,ref.arrayreftype<>art_none,finishandval); 2048 end; 2049 thlcgjvm.loadstoreopcnull2050 function thlcgjvm.loadstoreopc(def: tdef; isload, isarray: boolean; out finishandval: tcgint): tasmop; 2051 var 2052 size: longint; 2053 begin 2054 finishandval:=-1; 2055 case def2regtyp(def) of 2056 R_INTREGISTER: 2057 begin 2058 size:=def.size; 2059 if not isarray then 2060 begin 2061 case size of 2062 1,2,3,4: 2063 if isload then 2064 result:=a_iload 2065 else 2066 result:=a_istore; 2067 8: 2068 if isload then 2069 result:=a_lload 2070 else 2071 result:=a_lstore; 2072 else 2073 internalerror(2011032814); 2074 end; 2075 end 2076 { array } 2077 else if isload then 2078 begin 2079 case size of 2080 1: 2081 begin 2082 result:=a_baload; 2083 if not is_signed(def) and 2084 (def.typ=orddef) and 2085 (torddef(def).high>127) then 2086 finishandval:=255; 2087 end; 2088 2: 2089 begin 2090 if is_widechar(def) then 2091 result:=a_caload 2092 else 2093 begin 2094 result:=a_saload; 2095 { if we'd treat arrays of word as "array of widechar" we 2096 could use a_caload, but that would make for even more 2097 awkward interfacing with external Java code } 2098 if not is_signed(def) and 2099 (def.typ=orddef) and 2100 (torddef(def).high>32767) then 2101 finishandval:=65535; 2102 end; 2103 end; 2104 4: result:=a_iaload; 2105 8: result:=a_laload; 2106 else 2107 internalerror(2010120503); 2108 end 2109 end 2110 else 2111 begin 2112 case size of 2113 1: result:=a_bastore; 2114 2: if not is_widechar(def) then 2115 result:=a_sastore 2116 else 2117 result:=a_castore; 2118 4: result:=a_iastore; 2119 8: result:=a_lastore; 2120 else 2121 internalerror(2010120508); 2122 end 2123 end 2124 end; 2125 R_ADDRESSREGISTER: 2126 if not isarray then 2127 if isload then 2128 result:=a_aload 2129 else 2130 result:=a_astore 2131 else if isload then 2132 result:=a_aaload 2133 else 2134 result:=a_aastore; 2135 R_FPUREGISTER: 2136 begin 2137 case tfloatdef(def).floattype of 2138 s32real: 2139 if not isarray then 2140 if isload then 2141 result:=a_fload 2142 else 2143 result:=a_fstore 2144 else if isload then 2145 result:=a_faload 2146 else 2147 result:=a_fastore; 2148 s64real: 2149 if not isarray then 2150 if isload then 2151 result:=a_dload 2152 else 2153 result:=a_dstore 2154 else if isload then 2155 result:=a_daload 2156 else 2157 result:=a_dastore; 2158 else 2159 internalerror(2010120504); 2160 end 2161 end 2162 else 2163 internalerror(2010120502); 2164 end; 2165 end; 2166 2167 procedure thlcgjvm.resize_stack_int_val(list: TAsmList; fromsize, tosize: tdef; formemstore: boolean); 2168 var 2169 fromcgsize, tocgsize: tcgsize; 2170 begin 2171 { When storing to an array, field or global variable, make sure the 2172 static type verification can determine that the stored value fits 2173 within the boundaries of the declared type (to appease the Dalvik VM). 2174 Local variables either get their type upgraded in the debug info, 2175 or have no type information at all } 2176 if formemstore and 2177 (tosize.typ=orddef) then 2178 if (torddef(tosize).ordtype in [u8bit,uchar]) then 2179 tosize:=s8inttype 2180 else if torddef(tosize).ordtype=u16bit then 2181 tosize:=s16inttype; 2182 2183 fromcgsize:=def_cgsize(fromsize); 2184 tocgsize:=def_cgsize(tosize); 2185 if fromcgsize in [OS_S64,OS_64] then 2186 begin 2187 if not(tocgsize in [OS_S64,OS_64]) then 2188 begin 2189 { truncate } 2190 list.concat(taicpu.op_none(a_l2i)); 2191 decstack(list,1); 2192 end; 2193 end 2194 else if tocgsize in [OS_S64,OS_64] then 2195 begin 2196 { extend } 2197 list.concat(taicpu.op_none(a_i2l)); 2198 incstack(list,1); 2199 { if it was an unsigned 32 bit value, remove sign extension } 2200 if fromcgsize=OS_32 then 2201 a_op_const_stack(list,OP_AND,s64inttype,cardinal($ffffffff)); 2202 end; 2203 { Conversions between 32 and 64 bit types have been completely handled 2204 above. We still may have to truncate or sign extend in case the 2205 destination type is smaller that the source type, or has a different 2206 sign. In case the destination is a widechar and the source is not, we 2207 also have to insert a conversion to widechar. 2208 2209 In case of Dalvik, we also have to insert conversions for e.g. byte 2210 -> smallint, because truncating a byte happens via "and 255", and the 2211 result is a longint in Dalvik's type verification model (so we have 2212 to "truncate" it back to smallint) } 2213 if (not(fromcgsize in [OS_S64,OS_64,OS_32,OS_S32]) or 2214 not(tocgsize in [OS_S64,OS_64,OS_32,OS_S32])) and 2215 (((current_settings.cputype=cpu_dalvik) and 2216 not(tocgsize in [OS_32,OS_S32]) and 2217 not is_signed(fromsize) and 2218 is_signed(tosize)) or 2219 (tcgsize2size[fromcgsize]>tcgsize2size[tocgsize]) or 2220 ((tcgsize2size[fromcgsize]=tcgsize2size[tocgsize]) and 2221 (fromcgsize<>tocgsize)) or 2222 { needs to mask out the sign in the top 16 bits } 2223 ((fromcgsize=OS_S8) and 2224 (tocgsize=OS_16)) or 2225 ((tosize=cwidechartype) and 2226 (fromsize<>cwidechartype))) then 2227 case tocgsize of 2228 OS_8: 2229 a_op_const_stack(list,OP_AND,s32inttype,255); 2230 OS_S8: 2231 list.concat(taicpu.op_none(a_i2b)); 2232 OS_16: 2233 if (tosize.typ=orddef) and 2234 (torddef(tosize).ordtype=uwidechar) then 2235 list.concat(taicpu.op_none(a_i2c)) 2236 else 2237 a_op_const_stack(list,OP_AND,s32inttype,65535); 2238 OS_S16: 2239 list.concat(taicpu.op_none(a_i2s)); 2240 end; 2241 end; 2242 2243 procedure thlcgjvm.maybe_resize_stack_para_val(list: TAsmList; retdef: tdef; callside: boolean); 2244 var 2245 convsize: tdef; 2246 begin 2247 if (retdef.typ=orddef) then 2248 begin 2249 if (torddef(retdef).ordtype in [u8bit,u16bit,uchar]) and 2250 (torddef(retdef).high>=(1 shl (retdef.size*8-1))) then 2251 begin 2252 convsize:=nil; 2253 if callside then 2254 if torddef(retdef).ordtype in [u8bit,uchar] then 2255 convsize:=s8inttype 2256 else 2257 convsize:=s16inttype 2258 else if torddef(retdef).ordtype in [u8bit,uchar] then 2259 convsize:=u8inttype 2260 else 2261 convsize:=u16inttype; 2262 if assigned(convsize) then 2263 resize_stack_int_val(list,s32inttype,convsize,false); 2264 end; 2265 end; 2266 end; 2267 2268 2269 procedure thlcgjvm.g_adjust_stack_after_call(list: TAsmList; pd: tabstractprocdef; paraheight: longint; forceresdef: tdef); 2270 var 2271 totalremovesize: longint; 2272 realresdef: tdef; 2273 begin 2274 if not assigned(forceresdef) then 2275 realresdef:=pd.returndef 2276 else 2277 realresdef:=forceresdef; 2278 { a constructor doesn't actually return a value in the jvm } 2279 if (tabstractprocdef(pd).proctypeoption=potype_constructor) then 2280 totalremovesize:=paraheight 2281 else 2282 { even a byte takes up a full stackslot -> align size to multiple of 4 } 2283 totalremovesize:=paraheight-(align(realresdef.size,4) shr 2); 2284 { remove parameters from internal evaluation stack counter (in case of 2285 e.g. no parameters and a result, it can also increase) } 2286 if totalremovesize>0 then 2287 decstack(list,totalremovesize) 2288 else if totalremovesize<0 then 2289 incstack(list,-totalremovesize); 2290 end; 2291 2292 2293 procedure thlcgjvm.allocate_implicit_struct_with_base_ref(list: TAsmList; vs: tabstractvarsym; ref: treference); 2294 var 2295 tmpref: treference; 2296 begin 2297 ref.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname,AT_DATA); 2298 tg.gethltemp(list,vs.vardef,vs.vardef.size,tt_persistent,tmpref); 2299 { only copy the reference, not the actual data } 2300 a_load_ref_ref(list,java_jlobject,java_jlobject,tmpref,ref); 2301 { remains live since there's still a reference to the created 2302 entity } 2303 tg.ungettemp(list,tmpref); 2304 end; 2305 2306 2307 procedure thlcgjvm.allocate_enum_with_base_ref(list: TAsmList; vs: tabstractvarsym; const initref: treference; destbaseref: treference); 2308 begin 2309 destbaseref.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname,AT_DATA); 2310 { only copy the reference, not the actual data } 2311 a_load_ref_ref(list,java_jlobject,java_jlobject,initref,destbaseref); 2312 end; 2313 2314 thlcgjvm.get_enum_init_val_refnull2315 function thlcgjvm.get_enum_init_val_ref(def: tdef; out ref: treference): boolean; 2316 var 2317 sym: tstaticvarsym; 2318 begin 2319 result:=false; 2320 sym:=tstaticvarsym(tcpuenumdef(tenumdef(def).getbasedef).classdef.symtable.Find('__FPC_ZERO_INITIALIZER')); 2321 { no enum with ordinal value 0 -> exit } 2322 if not assigned(sym) then 2323 exit; 2324 reference_reset_symbol(ref,current_asmdata.RefAsmSymbol(sym.mangledname,AT_DATA),0,4,[]); 2325 result:=true; 2326 end; 2327 2328 2329 procedure thlcgjvm.allocate_implicit_structs_for_st_with_base_ref(list: TAsmList; st: tsymtable; const ref: treference; allocvartyp: tsymtyp); 2330 var 2331 vs: tabstractvarsym; 2332 def: tdef; 2333 i: longint; 2334 initref: treference; 2335 begin 2336 for i:=0 to st.symlist.count-1 do 2337 begin 2338 if (tsym(st.symlist[i]).typ<>allocvartyp) then 2339 continue; 2340 vs:=tabstractvarsym(st.symlist[i]); 2341 if sp_static in vs.symoptions then 2342 continue; 2343 { vo_is_external and vo_has_local_copy means a staticvarsym that is 2344 alias for a constsym, whose sole purpose is for allocating and 2345 intialising the constant } 2346 if [vo_is_external,vo_has_local_copy]*vs.varoptions=[vo_is_external] then 2347 continue; 2348 { threadvar innitializations are handled at the node tree level } 2349 if vo_is_thread_var in vs.varoptions then 2350 begin 2351 { nothing } 2352 end 2353 else if jvmimplicitpointertype(vs.vardef) then 2354 allocate_implicit_struct_with_base_ref(list,vs,ref) 2355 { enums are class instances in Java, while they are ordinals in 2356 Pascal. When they are initialized with enum(0), such as in 2357 constructors or global variables, initialize them with the 2358 enum instance for 0 if it exists (if not, it remains nil since 2359 there is no valid enum value in it) } 2360 else if (vs.vardef.typ=enumdef) and 2361 ((vs.typ<>fieldvarsym) or 2362 (tdef(vs.owner.defowner).typ<>objectdef) or 2363 (ts_jvm_enum_field_init in current_settings.targetswitches)) and 2364 get_enum_init_val_ref(vs.vardef,initref) then 2365 allocate_enum_with_base_ref(list,vs,initref,ref); 2366 end; 2367 { process symtables of routines part of this symtable (for local typed 2368 constants) } 2369 if allocvartyp=staticvarsym then 2370 begin 2371 for i:=0 to st.deflist.count-1 do 2372 begin 2373 def:=tdef(st.deflist[i]); 2374 { the unit symtable also contains the methods of classes defined 2375 in that unit -> skip them when processing the unit itself. 2376 Localst is not assigned for the main program code. 2377 Localst can be the same as st in case of unit init code. } 2378 if (def.typ<>procdef) or 2379 (def.owner<>st) or 2380 not assigned(tprocdef(def).localst) or 2381 (tprocdef(def).localst=st) then 2382 continue; 2383 allocate_implicit_structs_for_st_with_base_ref(list,tprocdef(def).localst,ref,allocvartyp); 2384 end; 2385 end; 2386 end; 2387 2388 procedure thlcgjvm.gen_initialize_fields_code(list: TAsmList); 2389 var 2390 sym: tsym; 2391 selfpara: tparavarsym; 2392 selfreg: tregister; 2393 ref: treference; 2394 obj: tabstractrecorddef; 2395 i: longint; 2396 needinit: boolean; 2397 begin 2398 obj:=tabstractrecorddef(current_procinfo.procdef.owner.defowner); 2399 { check whether there are any fields that need initialisation } 2400 needinit:=false; 2401 for i:=0 to obj.symtable.symlist.count-1 do 2402 begin 2403 sym:=tsym(obj.symtable.symlist[i]); 2404 if (sym.typ=fieldvarsym) and 2405 not(sp_static in sym.symoptions) and 2406 (jvmimplicitpointertype(tfieldvarsym(sym).vardef) or 2407 ((tfieldvarsym(sym).vardef.typ=enumdef) and 2408 get_enum_init_val_ref(tfieldvarsym(sym).vardef,ref))) then 2409 begin 2410 needinit:=true; 2411 break; 2412 end; 2413 end; 2414 if not needinit then 2415 exit; 2416 selfpara:=tparavarsym(current_procinfo.procdef.parast.find('self')); 2417 if not assigned(selfpara) then 2418 internalerror(2011033001); 2419 selfreg:=getaddressregister(list,selfpara.vardef); 2420 a_load_loc_reg(list,obj,obj,selfpara.localloc,selfreg); 2421 cgutils.reference_reset_base(ref,selfreg,0,ctempposinvalid,1,[]); 2422 allocate_implicit_structs_for_st_with_base_ref(list,obj.symtable,ref,fieldvarsym); 2423 end; 2424 2425 procedure thlcgjvm.gen_typecheck(list: TAsmList; checkop: tasmop; checkdef: tdef); 2426 begin 2427 { replace special types with their equivalent class type } 2428 if (checkdef.typ=pointerdef) and 2429 jvmimplicitpointertype(tpointerdef(checkdef).pointeddef) then 2430 checkdef:=tpointerdef(checkdef).pointeddef; 2431 if (checkdef=voidpointertype) or 2432 (checkdef.typ=formaldef) then 2433 checkdef:=java_jlobject 2434 else if checkdef.typ=enumdef then 2435 checkdef:=tcpuenumdef(checkdef).classdef 2436 else if checkdef.typ=setdef then 2437 begin 2438 if tsetdef(checkdef).elementdef.typ=enumdef then 2439 checkdef:=java_juenumset 2440 else 2441 checkdef:=java_jubitset; 2442 end 2443 else if checkdef.typ=procvardef then 2444 checkdef:=tcpuprocvardef(checkdef).classdef 2445 else if is_wide_or_unicode_string(checkdef) then 2446 checkdef:=java_jlstring 2447 else if is_ansistring(checkdef) then 2448 checkdef:=java_ansistring 2449 else if is_shortstring(checkdef) then 2450 checkdef:=java_shortstring; 2451 if checkdef.typ in [objectdef,recorddef] then 2452 list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol(tabstractrecorddef(checkdef).jvm_full_typename(true),AT_METADATA))) 2453 else if checkdef.typ=classrefdef then 2454 list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol('java/lang/Class',AT_METADATA))) 2455 else 2456 list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol(jvmencodetype(checkdef,false),AT_METADATA))); 2457 end; 2458 2459 procedure thlcgjvm.resizestackfpuval(list: TAsmList; fromsize, tosize: tcgsize); 2460 begin 2461 if (fromsize=OS_F32) and 2462 (tosize=OS_F64) then 2463 begin 2464 list.concat(taicpu.op_none(a_f2d)); 2465 incstack(list,1); 2466 end 2467 else if (fromsize=OS_F64) and 2468 (tosize=OS_F32) then 2469 begin 2470 list.concat(taicpu.op_none(a_d2f)); 2471 decstack(list,1); 2472 end; 2473 end; 2474 2475 procedure thlcgjvm.maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean); 2476 begin 2477 if (op=OP_DIV) and 2478 (def_cgsize(size)=OS_32) then 2479 begin 2480 { needs zero-extension to 64 bit, because the JVM only supports 2481 signed divisions } 2482 resize_stack_int_val(list,u32inttype,s64inttype,false); 2483 op:=OP_IDIV; 2484 isdivu32:=true; 2485 end 2486 else 2487 isdivu32:=false; 2488 end; 2489 thlcgjvm.a_call_name_internnull2490 function thlcgjvm.a_call_name_intern(list: TAsmList; pd: tprocdef; const s: TSymStr; forceresdef: tdef; inheritedcall: boolean): tcgpara; 2491 var 2492 opc: tasmop; 2493 begin 2494 { 2495 invoke types: 2496 * invokeinterface: call method from an interface (must also specify 2497 number of parameters in terms of stack slot count!) 2498 * invokespecial: invoke a constructor, method in a superclass, 2499 or private instance method 2500 * invokestatic: invoke a class method (private or not) 2501 * invokevirtual: invoke a regular method 2502 } 2503 case pd.owner.symtabletype of 2504 globalsymtable, 2505 staticsymtable, 2506 localsymtable: 2507 { regular and nested procedures are turned into static methods } 2508 opc:=a_invokestatic; 2509 objectsymtable: 2510 begin 2511 case tobjectdef(pd.owner.defowner).objecttype of 2512 odt_javaclass: 2513 begin 2514 if (po_classmethod in pd.procoptions) or 2515 (pd.proctypeoption=potype_operator) then 2516 opc:=a_invokestatic 2517 else if (pd.visibility=vis_strictprivate) or 2518 (pd.proctypeoption=potype_constructor) or 2519 inheritedcall then 2520 opc:=a_invokespecial 2521 else 2522 opc:=a_invokevirtual; 2523 end; 2524 odt_interfacejava: 2525 { static interface methods are not allowed } 2526 opc:=a_invokeinterface; 2527 else 2528 internalerror(2010122601); 2529 end; 2530 end; 2531 recordsymtable: 2532 begin 2533 if (po_staticmethod in pd.procoptions) or 2534 (pd.proctypeoption=potype_operator) then 2535 opc:=a_invokestatic 2536 else if (pd.visibility=vis_strictprivate) or 2537 (pd.proctypeoption=potype_constructor) or 2538 inheritedcall then 2539 opc:=a_invokespecial 2540 else 2541 opc:=a_invokevirtual; 2542 end 2543 else 2544 internalerror(2010122602); 2545 end; 2546 if (opc<>a_invokeinterface) then 2547 list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(s,AT_FUNCTION))) elsenull2548 else 2549 begin 2550 pd.init_paraloc_info(calleeside); 2551 list.concat(taicpu.op_sym_const(opc,current_asmdata.RefAsmSymbol(s,AT_FUNCTION),pd.calleeargareasize)); 2552 end; 2553 result:=get_call_result_cgpara(pd,forceresdef); 2554 end; 2555 2556 procedure create_hlcodegen; 2557 begin 2558 hlcg:=thlcgjvm.create; 2559 create_codegen; 2560 end; 2561 2562 begin 2563 chlcgobj:=thlcgjvm; 2564 end. 2565