From 184c55949647b30f745334eb17db5778af3c0007 Mon Sep 17 00:00:00 2001 From: nickysn Date: Wed, 29 Jul 2020 16:06:57 +0000 Subject: [PATCH] [PATCH 03/83] adding WASM specific files From 3e72f04bc65f3da24efdf55a3102ef21479ff567 Mon Sep 17 00:00:00 2001 From: Dmitry Boyarintsev Date: Wed, 28 Aug 2019 17:01:46 -0400 git-svn-id: branches/wasm@45880 - --- .gitattributes | 23 + compiler/systems/t_wasm.pas | 7 + compiler/utils/mkwasmreg.pp | 265 ++++ compiler/wasm/aasmcpu.pas | 301 ++++ compiler/wasm/agwat.pas | 30 + compiler/wasm/cgcpu.pas | 129 ++ compiler/wasm/cpubase.pas | 358 +++++ compiler/wasm/cpuinfo.pas | 107 ++ compiler/wasm/cpunode.pas | 45 + compiler/wasm/cpupara.pas | 329 +++++ compiler/wasm/cpupi.pas | 65 + compiler/wasm/cputarg.pas | 64 + compiler/wasm/hlcgcpu.pas | 2587 +++++++++++++++++++++++++++++++++++ compiler/wasm/rgcpu.pas | 417 ++++++ compiler/wasm/rwasmcon.inc | 5 + compiler/wasm/rwasmnor.inc | 2 + compiler/wasm/rwasmnum.inc | 5 + compiler/wasm/rwasmrni.inc | 5 + compiler/wasm/rwasmsri.inc | 5 + compiler/wasm/rwasmstd.inc | 5 + compiler/wasm/rwasmsup.inc | 5 + compiler/wasm/symcpu.pas | 954 +++++++++++++ compiler/wasm/wasmdef.pas | 58 + compiler/wasm/wasmreg.dat | 20 + 24 files changed, 5791 insertions(+) create mode 100644 compiler/systems/t_wasm.pas create mode 100644 compiler/utils/mkwasmreg.pp create mode 100644 compiler/wasm/aasmcpu.pas create mode 100644 compiler/wasm/agwat.pas create mode 100644 compiler/wasm/cgcpu.pas create mode 100644 compiler/wasm/cpubase.pas create mode 100644 compiler/wasm/cpuinfo.pas create mode 100644 compiler/wasm/cpunode.pas create mode 100644 compiler/wasm/cpupara.pas create mode 100644 compiler/wasm/cpupi.pas create mode 100644 compiler/wasm/cputarg.pas create mode 100644 compiler/wasm/hlcgcpu.pas create mode 100644 compiler/wasm/rgcpu.pas create mode 100644 compiler/wasm/rwasmcon.inc create mode 100644 compiler/wasm/rwasmnor.inc create mode 100644 compiler/wasm/rwasmnum.inc create mode 100644 compiler/wasm/rwasmrni.inc create mode 100644 compiler/wasm/rwasmsri.inc create mode 100644 compiler/wasm/rwasmstd.inc create mode 100644 compiler/wasm/rwasmsup.inc create mode 100644 compiler/wasm/symcpu.pas create mode 100644 compiler/wasm/wasmdef.pas create mode 100644 compiler/wasm/wasmreg.dat diff --git a/.gitattributes b/.gitattributes index da3d9dab78..2c26639fe7 100644 --- a/.gitattributes +++ b/.gitattributes @@ -871,6 +871,7 @@ compiler/systems/t_os2.pas svneol=native#text/plain compiler/systems/t_palmos.pas svneol=native#text/plain compiler/systems/t_sunos.pas svneol=native#text/plain compiler/systems/t_symbian.pas svneol=native#text/plain +compiler/systems/t_wasm.pas svneol=native#text/plain compiler/systems/t_watcom.pas svneol=native#text/plain compiler/systems/t_wdosx.pas svneol=native#text/plain compiler/systems/t_wii.pas svneol=native#text/plain @@ -902,6 +903,7 @@ compiler/utils/mkjvmreg.pp svneol=native#text/plain compiler/utils/mkmpsreg.pp svneol=native#text/plain compiler/utils/mkppcreg.pp svneol=native#text/plain compiler/utils/mkspreg.pp svneol=native#text/plain +compiler/utils/mkwasmreg.pp svneol=native#text/plain compiler/utils/mkx86ins.pp svneol=native#text/plain compiler/utils/mkx86reg.pp svneol=native#text/plain compiler/utils/msg2inc.pp svneol=native#text/plain @@ -916,6 +918,27 @@ compiler/utils/ppuutils/ppuxml.pp svneol=native#text/plain compiler/utils/samplecfg svneol=native#text/plain compiler/verbose.pas svneol=native#text/plain compiler/version.pas svneol=native#text/plain +compiler/wasm/aasmcpu.pas svneol=native#text/plain +compiler/wasm/agwat.pas svneol=native#text/plain +compiler/wasm/cgcpu.pas svneol=native#text/plain +compiler/wasm/cpubase.pas svneol=native#text/plain +compiler/wasm/cpuinfo.pas svneol=native#text/plain +compiler/wasm/cpunode.pas svneol=native#text/plain +compiler/wasm/cpupara.pas svneol=native#text/plain +compiler/wasm/cpupi.pas svneol=native#text/plain +compiler/wasm/cputarg.pas svneol=native#text/plain +compiler/wasm/hlcgcpu.pas svneol=native#text/plain +compiler/wasm/rgcpu.pas svneol=native#text/plain +compiler/wasm/rwasmcon.inc svneol=native#text/plain +compiler/wasm/rwasmnor.inc svneol=native#text/plain +compiler/wasm/rwasmnum.inc svneol=native#text/plain +compiler/wasm/rwasmrni.inc svneol=native#text/plain +compiler/wasm/rwasmsri.inc svneol=native#text/plain +compiler/wasm/rwasmstd.inc svneol=native#text/plain +compiler/wasm/rwasmsup.inc svneol=native#text/plain +compiler/wasm/symcpu.pas svneol=native#text/plain +compiler/wasm/wasmdef.pas svneol=native#text/plain +compiler/wasm/wasmreg.dat svneol=native#text/plain compiler/widestr.pas svneol=native#text/plain compiler/wpo.pas svneol=native#text/plain compiler/wpobase.pas svneol=native#text/plain diff --git a/compiler/systems/t_wasm.pas b/compiler/systems/t_wasm.pas new file mode 100644 index 0000000000..53b25527be --- /dev/null +++ b/compiler/systems/t_wasm.pas @@ -0,0 +1,7 @@ +unit t_wasm; + +interface + +implementation + +end. diff --git a/compiler/utils/mkwasmreg.pp b/compiler/utils/mkwasmreg.pp new file mode 100644 index 0000000000..f7600429db --- /dev/null +++ b/compiler/utils/mkwasmreg.pp @@ -0,0 +1,265 @@ +{ + Copyright (c) 1998-2002 by Peter Vreman and Florian Klaempfl + + Convert wasmreg.dat to several .inc files for usage with + the Free pascal compiler + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +program mkspreg; + +const Version = '1.00'; + max_regcount = 200; + +var s : string; + i : longint; + line : longint; + regcount:byte; + regcount_bsstart:byte; + names, + regtypes, + subtypes, + supregs, + numbers, + stdnames : array[0..max_regcount-1] of string[63]; + regnumber_index, + std_regname_index : array[0..max_regcount-1] of byte; + +function tostr(l : longint) : string; + +begin + str(l,tostr); +end; + +function readstr : string; + + var + result : string; + + begin + result:=''; + while (s[i]<>',') and (i<=length(s)) do + begin + result:=result+s[i]; + inc(i); + end; + readstr:=result; + end; + + +procedure readcomma; + begin + if s[i]<>',' then + begin + writeln('Missing "," at line ',line); + writeln('Line: "',s,'"'); + halt(1); + end; + inc(i); + end; + + +procedure skipspace; + + begin + while (s[i] in [' ',#9]) do + inc(i); + end; + +procedure openinc(var f:text;const fn:string); +begin + writeln('creating ',fn); + assign(f,fn); + rewrite(f); + writeln(f,'{ don''t edit, this file is generated from wasmreg.dat }'); +end; + + +procedure closeinc(var f:text); +begin + writeln(f); + close(f); +end; + +procedure build_regnum_index; + +var h,i,j,p,t:byte; + +begin + {Build the registernumber2regindex index. + Step 1: Fill.} + for i:=0 to regcount-1 do + regnumber_index[i]:=i; + {Step 2: Sort. We use a Shell-Metzner sort.} + p:=regcount_bsstart; + repeat + for h:=0 to regcount-p-1 do + begin + i:=h; + repeat + j:=i+p; + if numbers[regnumber_index[j]]>=numbers[regnumber_index[i]] then + break; + t:=regnumber_index[i]; + regnumber_index[i]:=regnumber_index[j]; + regnumber_index[j]:=t; + if i

=stdnames[std_regname_index[i]] then + break; + t:=std_regname_index[i]; + std_regname_index[i]:=std_regname_index[j]; + std_regname_index[j]:=t; + if i

'$' then + begin + writeln('Missing $ before number, at line ',line); + writeln('Line: "',s,'"'); + halt(1); + end; + numbers[regcount]:=regtypes[regcount]+copy(subtypes[regcount],2,255)+'00'+copy(supregs[regcount],2,255); + if imax_regcount then + begin + writeln('Error: Too much registers, please increase maxregcount in source'); + halt(2); + end; + end; + close(infile); +end; + +procedure write_inc_files; + +var + norfile,stdfile,supfile, + numfile,confile, + rnifile,srifile:text; + first:boolean; + +begin + { create inc files } + openinc(confile,'rwasmcon.inc'); + openinc(supfile,'rwasmsup.inc'); + openinc(numfile,'rwasmnum.inc'); + openinc(stdfile,'rwasmstd.inc'); + openinc(norfile,'rwasmnor.inc'); + openinc(rnifile,'rwasmrni.inc'); + openinc(srifile,'rwasmsri.inc'); + first:=true; + for i:=0 to regcount-1 do + begin + if not first then + begin + writeln(numfile,','); + writeln(stdfile,','); + writeln(rnifile,','); + writeln(srifile,','); + end + else + first:=false; + writeln(supfile,'RS_',names[i],' = ',supregs[i],';'); + writeln(confile,'NR_'+names[i],' = ','tregister(',numbers[i],')',';'); + write(numfile,'tregister(',numbers[i],')'); + write(stdfile,'''',stdnames[i],''''); + write(rnifile,regnumber_index[i]); + write(srifile,std_regname_index[i]); + end; + write(norfile,regcount); + close(confile); + close(supfile); + closeinc(numfile); + closeinc(stdfile); + closeinc(norfile); + closeinc(rnifile); + closeinc(srifile); + writeln('Done!'); + writeln(regcount,' registers procesed'); +end; + + +begin + writeln('Register Table Converter Version ',Version); + line:=0; + regcount:=0; + read_spreg_file; + regcount_bsstart:=1; + while 2*regcount_bsstarttop_single then + clearop(opidx); + sval:=f; + typ:=top_single; + end; + end; + + + procedure taicpu.loaddouble(opidx: longint; d: double); + begin + allocate_oper(opidx+1); + with oper[opidx]^ do + begin + if typ<>top_double then + clearop(opidx); + dval:=d; + typ:=top_double; + end; + end; + + + {procedure taicpu.loadstr(opidx: longint; vallen: aint; pc: pchar); + begin + allocate_oper(opidx+1); + with oper[opidx]^ do + begin + clearop(opidx); + pcvallen:=vallen; + getmem(pcval,vallen); + move(pc^,pcval^,vallen); + typ:=top_string; + end; + end; + + + procedure taicpu.loadpwstr(opidx:longint;pwstr:pcompilerwidestring); + begin + allocate_oper(opidx+1); + with oper[opidx]^ do + begin + clearop(opidx); + initwidestring(pwstrval); + copywidestring(pwstr,pwstrval); + typ:=top_wstring; + end; + end;} + + + function taicpu.is_same_reg_move(regtype: Tregistertype):boolean; + begin + result:=false; + end; + + + function taicpu.spilling_get_operation_type(opnr: longint): topertype; + begin + case opcode of + a_iinc: + result:=operand_readwrite; + a_aastore, + a_astore, + a_astore_0, + a_astore_1, + a_astore_2, + a_astore_3, + a_bastore, + a_castore, + a_dastore, + a_dstore, + a_dstore_0, + a_dstore_1, + a_dstore_2, + a_dstore_3, + a_fastore, + a_fstore, + a_fstore_0, + a_fstore_1, + a_fstore_2, + a_fstore_3, + a_iastore, + a_istore, + a_istore_0, + a_istore_1, + a_istore_2, + a_istore_3, + a_lastore, + a_lstore, + a_lstore_0, + a_lstore_1, + a_lstore_2, + a_lstore_3, + a_sastore: + result:=operand_write; + else + result:=operand_read; + end; + end; + + + function spilling_create_load(const ref:treference;r:tregister):Taicpu; + begin + internalerror(2010122614); + result:=nil; + end; + + + function spilling_create_store(r:tregister; const ref:treference):Taicpu; + begin + internalerror(2010122615); + result:=nil; + end; + + + procedure InitAsm; + begin + end; + + + procedure DoneAsm; + begin + end; + +begin + cai_cpu:=taicpu; + cai_align:=tai_align; + casmdata:=TAsmData; +end. diff --git a/compiler/wasm/agwat.pas b/compiler/wasm/agwat.pas new file mode 100644 index 0000000000..43a787fb88 --- /dev/null +++ b/compiler/wasm/agwat.pas @@ -0,0 +1,30 @@ +{ + Copyright (c) 1998-2010 by the Free Pascal team + + This unit implements the WebAssembly text writer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{ Unit for writing WebAssembly text (S-Expression) output. +} +unit agwat; + +interface + +implementation + +end. diff --git a/compiler/wasm/cgcpu.pas b/compiler/wasm/cgcpu.pas new file mode 100644 index 0000000000..9916f20d99 --- /dev/null +++ b/compiler/wasm/cgcpu.pas @@ -0,0 +1,129 @@ +{ + Copyright (c) 2019 by Dmitry Boyarintsev + + This unit implements the code generator for the WebAssembly + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cgcpu; + +{$i fpcdefs.inc} + +interface + + uses + globtype,parabase, + cgbase,cgutils,cgobj,cghlcpu, + aasmbase,aasmtai,aasmdata,aasmcpu, + cpubase,cpuinfo, + node,symconst,SymType,symdef, + rgcpu; + + type + TCgJvm=class(thlbasecgcpu) + public + procedure init_register_allocators;override; + procedure done_register_allocators;override; + function getintregister(list:TAsmList;size:Tcgsize):Tregister;override; + function getfpuregister(list:TAsmList;size:Tcgsize):Tregister;override; + function getaddressregister(list:TAsmList):Tregister;override; + procedure do_register_allocation(list:TAsmList;headertai:tai);override; + end; + + procedure create_codegen; + +implementation + + uses + globals,verbose,systems,cutils, + paramgr,fmodule, + tgobj, + procinfo,cpupi; + + +{**************************************************************************** + Assembler code +****************************************************************************} + + procedure tcgjvm.init_register_allocators; + begin + inherited init_register_allocators; +{$ifndef cpu64bitaddr} + rg[R_INTREGISTER]:=Trgcpu.create(R_INTREGISTER,R_SUBD, + [RS_R0],first_int_imreg,[]); +{$else not cpu64bitaddr} + rg[R_INTREGISTER]:=Trgcpu.create(R_INTREGISTER,R_SUBQ, + [RS_R0],first_int_imreg,[]); +{$endif not cpu64bitaddr} + rg[R_FPUREGISTER]:=trgcpu.create(R_FPUREGISTER,R_SUBFS, + [RS_R0],first_fpu_imreg,[]); + rg[R_MMREGISTER]:=trgcpu.create(R_MMREGISTER,R_SUBNONE, + [RS_R0],first_mm_imreg,[]); + end; + + + procedure tcgjvm.done_register_allocators; + begin + rg[R_INTREGISTER].free; + rg[R_FPUREGISTER].free; + rg[R_MMREGISTER].free; + inherited done_register_allocators; + end; + + + function tcgjvm.getintregister(list:TAsmList;size:Tcgsize):Tregister; + begin + if not(size in [OS_64,OS_S64]) then + result:=rg[R_INTREGISTER].getregister(list,R_SUBD) + else + result:=rg[R_INTREGISTER].getregister(list,R_SUBQ); + end; + + + function tcgjvm.getfpuregister(list:TAsmList;size:Tcgsize):Tregister; + begin + if size=OS_F64 then + result:=rg[R_FPUREGISTER].getregister(list,R_SUBFD) + else + result:=rg[R_FPUREGISTER].getregister(list,R_SUBFS); + end; + + + function tcgjvm.getaddressregister(list:TAsmList):Tregister; + begin + { avoid problems in the compiler where int and addr registers are + mixed for now; we currently don't have to differentiate between the + two as far as the jvm backend is concerned } + result:=rg[R_INTREGISTER].getregister(list,R_SUBD) + end; + + + procedure tcgjvm.do_register_allocation(list:TAsmList;headertai:tai); + begin + { We only run the "register allocation" once for an arbitrary allocator, + which will perform the register->temp mapping for all register types. + This allows us to easily reuse temps. } + trgcpu(rg[R_INTREGISTER]).do_all_register_allocation(list,headertai); + end; + + + procedure create_codegen; + begin + cg:=tcgjvm.Create; + end; + +end. diff --git a/compiler/wasm/cpubase.pas b/compiler/wasm/cpubase.pas new file mode 100644 index 0000000000..60c64cd003 --- /dev/null +++ b/compiler/wasm/cpubase.pas @@ -0,0 +1,358 @@ +{ + Copyright (c) 2019 by Free Pascal and Lazarus foundation + + Contains the base types for the WebAssembly + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +{ This Unit contains the base types for the Java Virtual Machine +} +unit cpubase; + +{$i fpcdefs.inc} + +interface + +uses + globtype, + aasmbase,cpuinfo,cgbase; + + +{***************************************************************************** + Assembler Opcodes +*****************************************************************************} + + type + TAsmOp=(A_None, + a_aaload, a_aastore, a_aconst_null, + a_aload, a_aload_0, a_aload_1, a_aload_2, a_aload_3, + a_anewarray, a_areturn, a_arraylength, + a_astore, a_astore_0, a_astore_1, a_astore_2, a_astore_3, + a_athrow, a_baload, a_bastore, a_bipush, a_breakpoint, + a_caload, a_castore, a_checkcast, + a_d2f, a_d2i, a_d2l, a_dadd, a_daload, a_dastore, a_dcmpg, a_dcmpl, + a_dconst_0, a_dconst_1, a_ddiv, + a_dload, a_dload_0, a_dload_1, a_dload_2, a_dload_3, + a_dmul, a_dneg, a_drem, a_dreturn, + a_dstore, a_dstore_0, a_dstore_1, a_dstore_2, a_dstore_3, + a_dsub, + a_dup, a_dup2, a_dup2_x1, a_dup2_x2, a_dup_x1, a_dup_x2, + a_f2d, a_f2i, a_f2l, a_fadd, a_faload, a_fastore, a_fcmpg, a_fcmpl, + a_fconst_0, a_fconst_1, a_fconst_2, a_fdiv, + a_fload, a_fload_0, a_fload_1, a_fload_2, a_fload_3, + a_fmul, a_fneg, a_frem, a_freturn, + a_fstore, a_fstore_0, a_fstore_1, a_fstore_2, a_fstore_3, + a_fsub, + a_getfield, a_getstatic, + a_goto, a_goto_w, + a_i2b, a_i2c, a_i2d, a_i2f, a_i2l, a_i2s, + a_iadd, a_iaload, a_iand, a_iastore, + a_iconst_m1, a_iconst_0, a_iconst_1, a_iconst_2, a_iconst_3, + a_iconst_4, a_iconst_5, + a_idiv, + a_if_acmpeq, a_if_acmpne, a_if_icmpeq, a_if_icmpge, a_if_icmpgt, + a_if_icmple, a_if_icmplt, a_if_icmpne, + a_ifeq, a_ifge, a_ifgt, a_ifle, a_iflt, a_ifne, a_ifnonnull, a_ifnull, + a_iinc, + a_iload, a_iload_0, a_iload_1, a_iload_2, a_iload_3, + a_imul, a_ineg, + a_instanceof, + a_invokeinterface, a_invokespecial, a_invokestatic, a_invokevirtual, + a_ior, a_irem, a_ireturn, a_ishl, a_ishr, + a_istore, a_istore_0, a_istore_1, a_istore_2, a_istore_3, + a_isub, a_iushr, a_ixor, + a_jsr, a_jsr_w, + a_l2d, a_l2f, a_l2i, a_ladd, a_laload, a_land, a_lastore, a_lcmp, + a_lconst_0, a_lconst_1, + a_ldc, a_ldc2_w, a_ldc_w, a_ldiv, + a_lload, a_lload_0, a_lload_1, a_lload_2, a_lload_3, + a_lmul, a_lneg, + a_lookupswitch, + a_lor, a_lrem, + a_lreturn, + a_lshl, a_lshr, + a_lstore, a_lstore_0, a_lstore_1, a_lstore_2, a_lstore_3, + a_lsub, a_lushr, a_lxor, + a_monitorenter, + a_monitorexit, + a_multianewarray, + a_new, + a_newarray, + a_nop, + a_pop, a_pop2, + a_putfield, a_putstatic, + a_ret, a_return, + a_saload, a_sastore, a_sipush, + a_swap, + a_tableswitch, + a_wide + ); + + {# This should define the array of instructions as string } + op2strtable=array[tasmop] of string[8]; + + Const + {# First value of opcode enumeration } + firstop = low(tasmop); + {# Last value of opcode enumeration } + lastop = high(tasmop); + + +{***************************************************************************** + Registers +*****************************************************************************} + + type + { Number of registers used for indexing in tables } + tregisterindex=0..{$i rwasmnor.inc}-1; // no registers in wasm + totherregisterset = set of tregisterindex; + + const + { Available Superregisters } + // there's no registers in wasm + {$i rwasmsup.inc} + + { No Subregisters } + R_SUBWHOLE = R_SUBNONE; + + { Available Registers } + // there's no registers in wasm + {$i rwasmcon.inc} + + { aliases } + { used as base register in references for parameters passed to + subroutines: these are passed on the evaluation stack, but this way we + can use the offset field to indicate the order, which is used by ncal + to sort the parameters } + NR_EVAL_STACK_BASE = NR_R0; + + maxvarregs = 1; + maxfpuvarregs = 1; + + { Integer Super registers first and last } + first_int_imreg = 2; + + { Float Super register first and last } + first_fpu_imreg = 2; + + { MM Super register first and last } + first_mm_imreg = 2; + + regnumber_table : array[tregisterindex] of tregister = ( + {$i rwasmnum.inc} + ); + + EVALSTACKLOCS = [LOC_REGISTER,LOC_CREGISTER,LOC_FPUREGISTER,LOC_CFPUREGISTER, + LOC_MMREGISTER,LOC_CMMREGISTER,LOC_SUBSETREG,LOC_CSUBSETREG]; + + +{***************************************************************************** + References +*****************************************************************************} + + type + { array reference types } + tarrayreftype = (art_none,art_indexreg,art_indexref,art_indexconst); + +{***************************************************************************** + Conditions +*****************************************************************************} + + type + // not used by jvm target + TAsmCond=(C_None); + +{***************************************************************************** + Constants +*****************************************************************************} + + const + max_operands = 2; + + +{***************************************************************************** + Default generic sizes +*****************************************************************************} + +{$ifdef cpu64bitaddr} + {# Defines the default address size for a processor, + -- fake for JVM, only influences default width of + arithmetic calculations } + OS_ADDR = OS_64; + {# the natural int size for a processor, + has to match osuinttype/ossinttype as initialized in psystem } + OS_INT = OS_64; + OS_SINT = OS_S64; +{$else} + {# Defines the default address size for a processor, + -- fake for JVM, only influences default width of + arithmetic calculations } + OS_ADDR = OS_32; + {# the natural int size for a processor, + has to match osuinttype/ossinttype as initialized in psystem } + OS_INT = OS_32; + OS_SINT = OS_S32; +{$endif} + {# the maximum float size for a processor, } + OS_FLOAT = OS_F64; + {# the size of a vector register for a processor } + OS_VECTOR = OS_M128; + +{***************************************************************************** + Generic Register names +*****************************************************************************} + + { dummies, not used for JVM } + + {# Stack pointer register } + { used as base register in references to indicate that it's a local } + NR_STACK_POINTER_REG = NR_R1; + RS_STACK_POINTER_REG = RS_R1; + {# Frame pointer register } + NR_FRAME_POINTER_REG = NR_STACK_POINTER_REG; + RS_FRAME_POINTER_REG = RS_STACK_POINTER_REG; + + { Java results are returned on the evaluation stack, not via a register } + + { Results are returned in this register (32-bit values) } + NR_FUNCTION_RETURN_REG = NR_NO; + RS_FUNCTION_RETURN_REG = RS_NO; + { Low part of 64bit return value } + NR_FUNCTION_RETURN64_LOW_REG = NR_NO; + RS_FUNCTION_RETURN64_LOW_REG = RS_NO; + { High part of 64bit return value } + NR_FUNCTION_RETURN64_HIGH_REG = NR_NO; + RS_FUNCTION_RETURN64_HIGH_REG = RS_NO; + { The value returned from a function is available in this register } + NR_FUNCTION_RESULT_REG = NR_FUNCTION_RETURN_REG; + RS_FUNCTION_RESULT_REG = RS_FUNCTION_RETURN_REG; + { The lowh part of 64bit value returned from a function } + NR_FUNCTION_RESULT64_LOW_REG = NR_FUNCTION_RETURN64_LOW_REG; + RS_FUNCTION_RESULT64_LOW_REG = RS_FUNCTION_RETURN64_LOW_REG; + { The high part of 64bit value returned from a function } + NR_FUNCTION_RESULT64_HIGH_REG = NR_FUNCTION_RETURN64_HIGH_REG; + RS_FUNCTION_RESULT64_HIGH_REG = RS_FUNCTION_RETURN64_HIGH_REG; + + NR_FPU_RESULT_REG = NR_NO; + NR_MM_RESULT_REG = NR_NO; + + +{***************************************************************************** + GCC /ABI linking information +*****************************************************************************} + + { dummies, not used for JVM } + + {# Required parameter alignment when calling a routine + } + std_param_align = 1; + + +{***************************************************************************** + CPU Dependent Constants +*****************************************************************************} + + maxfpuregs = 0; + +{***************************************************************************** + Helpers +*****************************************************************************} + + function cgsize2subreg(regtype: tregistertype; s:Tcgsize):Tsubregister; + function reg_cgsize(const reg: tregister) : tcgsize; + + function std_regnum_search(const s:string):Tregister; + function std_regname(r:Tregister):string; + function findreg_by_number(r:Tregister):tregisterindex; + + function eh_return_data_regno(nr: longint): longint; + + { since we don't use tasmconds, don't call this routine + (it will internalerror). We need it anyway to get aoptobj + to compile (but it won't execute it). + } + function inverse_cond(const c: TAsmCond): Tasmcond; {$ifdef USEINLINE}inline;{$endif USEINLINE} + +implementation + +uses + verbose, + rgbase; + +{***************************************************************************** + Helpers +*****************************************************************************} + + const + std_regname_table : array[tregisterindex] of string[15] = ( + {$i rwasmstd.inc} + ); + + regnumber_index : array[tregisterindex] of tregisterindex = ( + {$i rwasmrni.inc} + ); + + std_regname_index : array[tregisterindex] of tregisterindex = ( + {$i rwasmsri.inc} + ); + + function reg_cgsize(const reg: tregister): tcgsize; + begin + result:=OS_NO; + end; + + + function cgsize2subreg(regtype: tregistertype; s:Tcgsize):Tsubregister; + begin + cgsize2subreg:=R_SUBNONE; + end; + + + function std_regnum_search(const s:string):Tregister; + begin + result:=NR_NO; + end; + + + function findreg_by_number(r:Tregister):tregisterindex; + begin + result:=findreg_by_number_table(r,regnumber_index); + end; + + function std_regname(r:Tregister):string; + var + p : tregisterindex; + begin + p:=findreg_by_number_table(r,regnumber_index); + if p<>0 then + result:=std_regname_table[p] + else + result:=generic_regname(r); + end; + + function eh_return_data_regno(nr: longint): longint; + begin + result:=-1; + end; + + function inverse_cond(const c: TAsmCond): Tasmcond; {$ifdef USEINLINE}inline;{$endif USEINLINE} + begin + result:=C_None; + internalerror(2015082701); + end; + +end. diff --git a/compiler/wasm/cpuinfo.pas b/compiler/wasm/cpuinfo.pas new file mode 100644 index 0000000000..7d6e3be8ba --- /dev/null +++ b/compiler/wasm/cpuinfo.pas @@ -0,0 +1,107 @@ +{ + Copyright (c) 2010 by Free Pascal and Lazarus foundation + + Basic Processor information for the WebAssembly + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +Unit cpuinfo; + +{$i fpcdefs.inc} + +Interface + + uses + globtype; + +Type + bestreal = double; +{$if FPC_FULLVERSION>20700} + bestrealrec = TDoubleRec; +{$endif FPC_FULLVERSION>20700} + ts32real = single; + ts64real = double; + ts80real = extended; + ts128real = extended; + ts64comp = comp; + + pbestreal=^bestreal; + + { possible supported processors for this target } + tcputype = + (cpu_none, + { jvm, same as cpu_none } + cpu_jvm, + { jvm byte code to be translated into Dalvik bytecode: more type- + sensitive } + cpu_dalvik + ); + + tfputype = + (fpu_none, + fpu_standard + ); + + tcontrollertype = + (ct_none + ); + + tcontrollerdatatype = record + controllertypestr, controllerunitstr: string[20]; + cputype: tcputype; fputype: tfputype; + flashbase, flashsize, srambase, sramsize, eeprombase, eepromsize, bootbase, bootsize: dword; + end; + + +Const + { Is there support for dealing with multiple microcontrollers available } + { for this platform? } + ControllerSupport = false; + + { We know that there are fields after sramsize + but we don't care about this warning } + {$PUSH} + {$WARN 3177 OFF} + embedded_controllers : array [tcontrollertype] of tcontrollerdatatype = + ( + (controllertypestr:''; controllerunitstr:''; cputype:cpu_none; fputype:fpu_none; flashbase:0; flashsize:0; srambase:0; sramsize:0)); + {$POP} + + { calling conventions supported by the code generator } + supported_calling_conventions : tproccalloptions = [ + pocall_internproc + ]; + + cputypestr : array[tcputype] of string[9] = ('', + 'JVM', + 'JVMDALVIK' + ); + + fputypestr : array[tfputype] of string[8] = ( + 'NONE', + 'STANDARD' + ); + + { Supported optimizations, only used for information } + supported_optimizerswitches = genericlevel1optimizerswitches+ + genericlevel2optimizerswitches+ + genericlevel3optimizerswitches- + { no need to write info about those } + [cs_opt_level1,cs_opt_level2,cs_opt_level3]+ + [cs_opt_loopunroll,cs_opt_nodecse]; + + level1optimizerswitches = genericlevel1optimizerswitches; + level2optimizerswitches = genericlevel2optimizerswitches + level1optimizerswitches + [cs_opt_nodecse]; + level3optimizerswitches = genericlevel3optimizerswitches + level2optimizerswitches + [{,cs_opt_loopunroll}]; + level4optimizerswitches = genericlevel4optimizerswitches + level3optimizerswitches + []; + +Implementation + +end. diff --git a/compiler/wasm/cpunode.pas b/compiler/wasm/cpunode.pas new file mode 100644 index 0000000000..284c320017 --- /dev/null +++ b/compiler/wasm/cpunode.pas @@ -0,0 +1,45 @@ +{****************************************************************************** + Copyright (c) 2000-2010 by Florian Klaempfl and Jonas Maebe + + Includes the JVM code generator + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + *****************************************************************************} +unit cpunode; + +{$I fpcdefs.inc} + +interface +{ This unit is used to define the specific CPU implementations. All needed +actions are included in the INITALIZATION part of these units. This explains +the behaviour of such a unit having just a USES clause! } + +implementation + + uses + ncgbas,ncgflw,ncgcnv,ncgld,ncgmem,ncgcon,ncgset, + ncgadd, ncgcal,ncgmat,ncginl, + (* todo: WASM + njvmadd,njvmcal,njvmmat,njvmcnv,njvmcon,njvminl,njvmmem,njvmflw,njvmld, + njvmset,njvmvmt + { these are not really nodes } + ,rgcpu,tgcpu,njvmutil,njvmtcon, + *) + { symtable } + symcpu; + { no aasmdef, the WebAssembly uses the base TAsmData class (set in init code of aasmcpu) } + +end. diff --git a/compiler/wasm/cpupara.pas b/compiler/wasm/cpupara.pas new file mode 100644 index 0000000000..d411be6628 --- /dev/null +++ b/compiler/wasm/cpupara.pas @@ -0,0 +1,329 @@ +{ + Copyright (c) 1998-2010 by Florian Klaempfl, Jonas Maebe + + Calling conventions for the WebAssembly + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + *****************************************************************************} +unit cpupara; + +{$i fpcdefs.inc} + +interface + + uses + globtype, + cclasses, + aasmtai,aasmdata, + cpubase,cpuinfo, + symconst,symbase,symsym,symtype,symdef,paramgr,parabase,cgbase,cgutils; + + type + + { tcpuparamanager } + + tcpuparamanager=class(TParaManager) + function get_saved_registers_int(calloption: tproccalloption): tcpuregisterarray;override; + function push_high_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override; + function keep_para_array_range(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean; override; + function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override; + function push_copyout_param(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean; override; + function push_size(varspez: tvarspez; def: tdef; calloption: tproccalloption): longint;override; + {Returns a structure giving the information on the storage of the parameter + (which must be an integer parameter) + @param(nr Parameter number of routine, starting from 1)} + procedure getintparaloc(list: TAsmList; pd : tabstractprocdef; nr : longint; var cgpara : tcgpara);override; + function create_paraloc_info(p : TAbstractProcDef; side: tcallercallee):longint;override; + function create_varargs_paraloc_info(p : tabstractprocdef; side: tcallercallee; varargspara:tvarargsparalist):longint;override; + function get_funcretloc(p : tabstractprocdef; side: tcallercallee; forcetempdef: tdef): tcgpara;override; + function param_use_paraloc(const cgpara: tcgpara): boolean; override; + function ret_in_param(def:tdef;pd:tabstractprocdef):boolean;override; + function is_stack_paraloc(paraloc: pcgparalocation): boolean;override; + private + procedure create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee; paras: tparalist; + var parasize:longint); + end; + +implementation + + uses + cutils,verbose,systems, + defutil,wasmdef, + aasmcpu, + hlcgobj; + + + procedure tcpuparamanager.GetIntParaLoc(list: TAsmList; pd : tabstractprocdef; nr : longint; var cgpara : tcgpara); + begin + { not yet implemented/used } + internalerror(2010121001); + end; + + function tcpuparamanager.get_saved_registers_int(calloption: tproccalloption): tcpuregisterarray; + const + { dummy, not used for JVM } + saved_regs: {$ifndef VER3_0}tcpuregisterarray{$else}array [0..0] of tsuperregister{$endif} = (RS_NO); + begin + result:=saved_regs; + end; + + function tcpuparamanager.push_high_param(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean; + begin + { we don't need a separate high parameter, since all arrays in Java + have an implicit associated length } + if not is_open_array(def) and + not is_array_of_const(def) then + result:=inherited + else + result:=false; + end; + + + function tcpuparamanager.keep_para_array_range(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean; + begin + { even though these don't need a high parameter (see push_high_param), + we do have to keep the original parameter's array length because it's + used by the compiler (to determine the size of the array to construct + to pass to an array of const parameter) } + if not is_array_of_const(def) then + result:=inherited + else + result:=true; + end; + + + { true if a parameter is too large to copy and only the address is pushed } + function tcpuparamanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean; + begin + {result:= + jvmimplicitpointertype(def) or + ((def.typ=formaldef) and + not(varspez in [vs_var,vs_out]));} + //todo: + result := false; + end; + + + function tcpuparamanager.push_copyout_param(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean; + begin + { in principle also for vs_constref, but since we can't have real + references, that won't make a difference } + {result:= + (varspez in [vs_var,vs_out,vs_constref]) and + not jvmimplicitpointertype(def);} + Result := false; + end; + + + function tcpuparamanager.push_size(varspez: tvarspez; def: tdef; calloption: tproccalloption): longint; + begin + { all aggregate types are emulated using indirect pointer types } + if def.typ in [arraydef,recorddef,setdef,stringdef] then + result:=4 + else + result:=inherited; + end; + + + function tcpuparamanager.get_funcretloc(p : tabstractprocdef; side: tcallercallee; forcetempdef: tdef): tcgpara; + var + paraloc : pcgparalocation; + retcgsize : tcgsize; + begin + result.init; + result.alignment:=get_para_align(p.proccalloption); + if not assigned(forcetempdef) then + result.def:=p.returndef + else + begin + result.def:=forcetempdef; + result.temporary:=true; + end; + result.def:=get_para_push_size(result.def); + { void has no location } + if is_void(result.def) then + begin + paraloc:=result.add_location; + result.size:=OS_NO; + result.intsize:=0; + paraloc^.size:=OS_NO; + paraloc^.def:=voidtype; + paraloc^.loc:=LOC_VOID; + exit; + end; + { Constructors return self instead of a boolean } + if (p.proctypeoption=potype_constructor) then + begin + retcgsize:=OS_INT; + result.intsize:=sizeof(pint); + end + //todo: wasm should have the similar + {else if jvmimplicitpointertype(result.def) then + begin + retcgsize:=OS_ADDR; + result.def:=cpointerdef.getreusable_no_free(result.def); + end} + else + begin + retcgsize:=def_cgsize(result.def); + result.intsize:=result.def.size; + end; + result.size:=retcgsize; + + paraloc:=result.add_location; + { all values are returned on the evaluation stack } + paraloc^.loc:=LOC_REFERENCE; + paraloc^.reference.index:=NR_EVAL_STACK_BASE; + paraloc^.reference.offset:=0; + paraloc^.size:=result.size; + paraloc^.def:=result.def; + end; + + function tcpuparamanager.param_use_paraloc(const cgpara: tcgpara): boolean; + begin + { all parameters are copied by the VM to local variable locations } + result:=true; + end; + + function tcpuparamanager.ret_in_param(def:tdef;pd:tabstractprocdef):boolean; + begin + { not as efficient as returning in param for jvmimplicitpointertypes, + but in the latter case the routines are harder to use from Java + (especially for arrays), because the caller then manually has to + allocate the instance/array of the right size } + Result:=false; + end; + + function tcpuparamanager.is_stack_paraloc(paraloc: pcgparalocation): boolean; + begin + { all parameters are passed on the evaluation stack } + result:=true; + end; + + + function tcpuparamanager.create_varargs_paraloc_info(p : tabstractprocdef; side: tcallercallee; varargspara:tvarargsparalist):longint; + var + parasize : longint; + begin + parasize:=0; + { calculate the registers for the normal parameters } + create_paraloc_info_intern(p,side,p.paras,parasize); + { append the varargs } + if assigned(varargspara) then + begin + if side=callerside then + create_paraloc_info_intern(p,side,varargspara,parasize) + else + internalerror(2019021924); + end; + create_funcretloc_info(p,side); + result:=parasize; + end; + + + procedure tcpuparamanager.create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee;paras:tparalist; + var parasize:longint); + var + paraloc : pcgparalocation; + i : integer; + hp : tparavarsym; + paracgsize : tcgsize; + paraofs : longint; + paradef : tdef; + begin + paraofs:=0; + for i:=0 to paras.count-1 do + begin + hp:=tparavarsym(paras[i]); + if push_copyout_param(hp.varspez,hp.vardef,p.proccalloption) then + begin + { passed via array reference (instead of creating a new array + type for every single parameter, use java_jlobject) } + paracgsize:=OS_ADDR; + paradef:=java_jlobject; + end + //todo: wasm should have the similar + {else if jvmimplicitpointertype(hp.vardef) then + begin + paracgsize:=OS_ADDR; + paradef:=cpointerdef.getreusable_no_free(hp.vardef); + end} + else + begin + paracgsize:=def_cgsize(hp.vardef); + if paracgsize=OS_NO then + paracgsize:=OS_ADDR; + paradef:=hp.vardef; + end; + paradef:=get_para_push_size(paradef); + hp.paraloc[side].reset; + hp.paraloc[side].size:=paracgsize; + hp.paraloc[side].def:=paradef; + hp.paraloc[side].alignment:=std_param_align; + hp.paraloc[side].intsize:=tcgsize2size[paracgsize]; + paraloc:=hp.paraloc[side].add_location; + { All parameters are passed on the evaluation stack, pushed from + left to right (including self, if applicable). At the callee side, + they're available as local variables 0..n-1 (with 64 bit values + taking up two slots) } + paraloc^.loc:=LOC_REFERENCE;; + paraloc^.reference.offset:=paraofs; + paraloc^.size:=paracgsize; + paraloc^.def:=paradef; + case side of + callerside: + begin + paraloc^.loc:=LOC_REFERENCE; + { we use a fake loc_reference to indicate the stack location; + the offset (set above) will be used by ncal to order the + parameters so they will be pushed in the right order } + paraloc^.reference.index:=NR_EVAL_STACK_BASE; + end; + calleeside: + begin + paraloc^.loc:=LOC_REFERENCE; + paraloc^.reference.index:=NR_STACK_POINTER_REG; + end; + else + ; + end; + { 2 slots for 64 bit integers and floats, 1 slot for the rest } + if not(is_64bit(paradef) or + ((paradef.typ=floatdef) and + (tfloatdef(paradef).floattype=s64real))) then + inc(paraofs) + else + inc(paraofs,2); + end; + parasize:=paraofs; + end; + + + function tcpuparamanager.create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint; + var + parasize : longint; + begin + parasize:=0; + create_paraloc_info_intern(p,side,p.paras,parasize); + { Create Function result paraloc } + create_funcretloc_info(p,side); + { We need to return the size allocated on the stack } + result:=parasize; + end; + + +begin + ParaManager:=tcpuparamanager.create; +end. diff --git a/compiler/wasm/cpupi.pas b/compiler/wasm/cpupi.pas new file mode 100644 index 0000000000..57f5092a89 --- /dev/null +++ b/compiler/wasm/cpupi.pas @@ -0,0 +1,65 @@ +{ + Copyright (c) 2002-2010 by Florian Klaempfl and Jonas Maebe + + This unit contains the CPU specific part of tprocinfo + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cpupi; + +{$i fpcdefs.inc} + +interface + + uses + cutils, + procinfo,cpuinfo, + psub; + + type + + { tcpuprocinfo } + + tcpuprocinfo=class(tcgprocinfo) + public + procedure set_first_temp_offset;override; + end; + +implementation + + uses + systems,globals, + tgobj,paramgr,symconst; + + procedure tcpuprocinfo.set_first_temp_offset; + begin + { + Stackframe layout: + sp: + + sp+first_temp_offset: + + + } + procdef.init_paraloc_info(calleeside); + tg.setfirsttemp(procdef.calleeargareasize); + end; + + +begin + cprocinfo:=tcpuprocinfo; +end. diff --git a/compiler/wasm/cputarg.pas b/compiler/wasm/cputarg.pas new file mode 100644 index 0000000000..58860d95a8 --- /dev/null +++ b/compiler/wasm/cputarg.pas @@ -0,0 +1,64 @@ +{ + Copyright (c) by Dmitry Boyarintsev + + Includes the WebAssembly dependent target units + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit cputarg; + +{$i fpcdefs.inc} + +interface + + +implementation + + uses + systems { prevent a syntax error when nothing is included } + +{$ifndef NOOPT} +// ,aoptcpu +{$endif NOOPT} + +{************************************** + Targets +**************************************} + + {$ifndef NOTARGETSUNOS} + ,t_wasm + {$endif} + +{************************************** + Assemblers +**************************************} + + ,agwat + +{************************************** + Assembler Readers +**************************************} + +{************************************** + Debuginfo +**************************************} + + //,dbgjasm + + ; + +end. diff --git a/compiler/wasm/hlcgcpu.pas b/compiler/wasm/hlcgcpu.pas new file mode 100644 index 0000000000..a86bc3abec --- /dev/null +++ b/compiler/wasm/hlcgcpu.pas @@ -0,0 +1,2587 @@ +{ + Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe + Member of the Free Pascal development team + + This unit implements the WebAssembly high level code generator + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit hlcgcpu; + +{$i fpcdefs.inc} + +interface + +uses + globtype, + aasmbase,aasmdata, + symbase,symconst,symtype,symdef,symsym, + node, + cpubase, hlcgobj, cgbase, cgutils, parabase; + + type + + { thlcgjvm } + + thlcgjvm = class(thlcgobj) + private + fevalstackheight, + fmaxevalstackheight: longint; + public + constructor create; + + procedure incstack(list : TAsmList;slots: longint); + procedure decstack(list : TAsmList;slots: longint); + + class function def2regtyp(def: tdef): tregistertype; override; + + procedure a_load_const_cgpara(list : TAsmList;tosize : tdef;a : tcgint;const cgpara : TCGPara);override; + + function a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara;override; + function a_call_name_inherited(list : TAsmList;pd : tprocdef;const s : TSymStr; const paras: array of pcgpara): tcgpara;override; + function a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister; const paras: array of pcgpara): tcgpara; override; + + procedure a_load_const_reg(list : TAsmList;tosize : tdef;a : tcgint;register : tregister);override; + procedure a_load_const_ref(list : TAsmList;tosize : tdef;a : tcgint;const ref : treference);override; + procedure a_load_reg_ref(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);override; + procedure a_load_reg_reg(list : TAsmList;fromsize, tosize : tdef;reg1,reg2 : tregister);override; + procedure a_load_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);override; + procedure a_load_ref_ref(list : TAsmList;fromsize, tosize : tdef;const sref : treference;const dref : treference);override; + procedure a_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);override; + + procedure a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; reg: TRegister); override; + procedure a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister); override; + procedure a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; const ref: TReference); override; + + procedure a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); override; + procedure a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); override; + procedure a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); override; + procedure a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); override; + procedure a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation); override; + + procedure a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; const ref: treference; l: tasmlabel); override; + procedure a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel); override; + procedure a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel); override; + procedure a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel); override; + procedure a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); override; + + procedure a_jmp_always(list : TAsmList;l: tasmlabel); override; + + procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override; + procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);override; + + procedure a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference); override; + procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); override; + procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); override; + procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); override; + + procedure g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean); override; + procedure g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean); override; + + procedure gen_load_return_value(list:TAsmList);override; + procedure record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList); override; + + procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override; + procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); override; + procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override; + procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override; + + procedure g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); override; + procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation); override; + + procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);override; + procedure maybe_change_load_node_reg(list: TAsmList; var n: tnode; reload: boolean); override; + procedure g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); override; + procedure g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); override; + + procedure gen_initialize_code(list: TAsmList); override; + + procedure gen_entry_code(list: TAsmList); override; + procedure gen_exit_code(list: TAsmList); override; + + { unimplemented/unnecessary routines } + procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; srcsize, dstsize: tdef; src, dst: tregister); override; + procedure a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle); override; + procedure a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle); override; + procedure a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle); override; + procedure a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle); override; + procedure a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle); override; + procedure a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle); override; + procedure a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle); override; + procedure g_stackpointer_alloc(list: TAsmList; size: longint); override; + procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint); override; + procedure g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint); override; + procedure g_local_unwind(list: TAsmList; l: TAsmLabel); override; + + { JVM-specific routines } + + procedure a_load_stack_reg(list : TAsmList;size: tdef;reg: tregister); + { extra_slots are the slots that are used by the reference, and that + will be removed by the store operation } + procedure a_load_stack_ref(list : TAsmList;size: tdef;const ref: treference;extra_slots: longint); + procedure a_load_reg_stack(list : TAsmList;size: tdef;reg: tregister); + { extra_slots are the slots that are used by the reference, and that + will be removed by the load operation } + procedure a_load_ref_stack(list : TAsmList;size: tdef;const ref: treference;extra_slots: longint); + procedure a_load_const_stack(list : TAsmList;size: tdef;a :tcgint; typ: TRegisterType); + + procedure a_load_stack_loc(list : TAsmList;size: tdef;const loc: tlocation); + procedure a_load_loc_stack(list : TAsmList;size: tdef;const loc: tlocation); + + procedure a_loadfpu_const_stack(list : TAsmList;size: tdef;a :double); + + procedure a_op_stack(list : TAsmList;op: topcg; size: tdef; trunc32: boolean); + procedure a_op_const_stack(list : TAsmList;op: topcg; size: tdef;a : tcgint); + procedure a_op_reg_stack(list : TAsmList;op: topcg; size: tdef;reg: tregister); + procedure a_op_ref_stack(list : TAsmList;op: topcg; size: tdef;const ref: treference); + procedure a_op_loc_stack(list : TAsmList;op: topcg; size: tdef;const loc: tlocation); + + procedure g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation); override; + + { assumes that initdim dimensions have already been pushed on the + evaluation stack, and creates a new array of type arrdef with these + dimensions } + procedure g_newarray(list : TAsmList; arrdef: tdef; initdim: longint); + { gets the length of the array whose reference is stored in arrloc, + and puts it on the evaluation stack } + procedure g_getarraylen(list : TAsmList; const arrloc: tlocation); + + { this routine expects that all values are already massaged into the + required form (sign bits xor'ed for gt/lt comparisons for OS_32/OS_64, + see http://stackoverflow.com/questions/4068973/c-performing-signed-comparison-in-unsigned-variables-without-casting ) } + procedure a_cmp_stack_label(list : TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel); + { these 2 routines perform the massaging expected by the previous one } + procedure maybe_adjust_cmp_stackval(list : TAsmlist; size: tdef; cmp_op: topcmp); + function maybe_adjust_cmp_constval(size: tdef; cmp_op: topcmp; a: tcgint): tcgint; + { truncate/sign extend after performing operations on values < 32 bit + that may have overflowed outside the range } + procedure maybe_adjust_op_result(list: TAsmList; op: TOpCg; size: tdef); + + { performs sign/zero extension as required } + procedure resize_stack_int_val(list: TAsmList;fromsize,tosize: tdef; formemstore: boolean); + + { 8/16 bit unsigned parameters and return values must be sign-extended on + the producer side, because the JVM does not support unsigned variants; + then they have to be zero-extended again on the consumer side } + procedure maybe_resize_stack_para_val(list: TAsmList; retdef: tdef; callside: boolean); + + { adjust the stack height after a call based on the specified number of + slots used for parameters and the provided resultdef } + procedure g_adjust_stack_after_call(list: TAsmList; pd: tabstractprocdef; paraheight: longint; forceresdef: tdef); + + property maxevalstackheight: longint read fmaxevalstackheight; + + procedure gen_initialize_fields_code(list:TAsmList); + + procedure gen_typecheck(list: TAsmList; checkop: tasmop; checkdef: tdef); + protected + procedure a_load_const_stack_intern(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType; legalize_const: boolean); + + function get_enum_init_val_ref(def: tdef; out ref: treference): boolean; + + procedure allocate_implicit_structs_for_st_with_base_ref(list: TAsmList; st: tsymtable; const ref: treference; allocvartyp: tsymtyp); + procedure allocate_enum_with_base_ref(list: TAsmList; vs: tabstractvarsym; const initref: treference; destbaseref: treference); + procedure allocate_implicit_struct_with_base_ref(list: TAsmList; vs: tabstractvarsym; ref: treference); + procedure gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara); override; + + procedure g_copyvalueparas(p: TObject; arg: pointer); override; + + procedure inittempvariables(list:TAsmList);override; + + function g_call_system_proc_intern(list: TAsmList; pd: tprocdef; const paras: array of pcgpara; forceresdef: tdef): tcgpara; override; + + { in case of an array, the array base address and index have to be + put on the evaluation stack before the stored value; similarly, for + fields the self pointer has to be loaded first. Also checks whether + the reference is valid. If dup is true, the necessary values are stored + twice. Returns how many stack slots have been consumed, disregarding + the "dup". } + function prepare_stack_for_ref(list: TAsmList; const ref: treference; dup: boolean): longint; + { return the load/store opcode to load/store from/to ref; if the result + has to be and'ed after a load to get the final value, that constant + is returned in finishandval (otherwise that value is set to -1) } + function loadstoreopcref(def: tdef; isload: boolean; const ref: treference; out finishandval: tcgint): tasmop; + { return the load/store opcode to load/store from/to reg; if the result + has to be and'ed after a load to get the final value, that constant + is returned in finishandval (otherwise that value is set to -1) } + function loadstoreopc(def: tdef; isload, isarray: boolean; out finishandval: tcgint): tasmop; + procedure resizestackfpuval(list: TAsmList; fromsize, tosize: tcgsize); + { in case of an OS_32 OP_DIV, we have to use an OS_S64 OP_IDIV because the + JVM does not support unsigned divisions } + procedure maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean); + { common implementation of a_call_* } + function a_call_name_intern(list : TAsmList;pd : tprocdef;const s : TSymStr; forceresdef: tdef; inheritedcall: boolean): tcgpara; + + { concatcopy helpers } + procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference); + procedure concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference); + procedure concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference); + procedure concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference); + + end; + + + const + opcmp2if: array[topcmp] of tasmop = (A_None, + a_ifeq,a_ifgt,a_iflt,a_ifge,a_ifle, + a_ifne,a_ifle,a_iflt,a_ifge,a_ifgt); + +implementation + + uses + verbose,cutils,globals,fmodule,constexp, + defutil, + aasmtai,aasmcpu, + symtable,symcpu, wasmdef, + procinfo,cpuinfo,cgcpu,tgobj; + + const + TOpCG2IAsmOp : array[topcg] of TAsmOp=( { not = xor -1 } + 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 + ); + TOpCG2LAsmOp : array[topcg] of TAsmOp=( { not = xor -1 } + 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 + ); + + constructor thlcgjvm.create; + begin + fevalstackheight:=0; + fmaxevalstackheight:=0; + end; + + procedure thlcgjvm.incstack(list: TasmList;slots: longint); + begin + if slots=0 then + exit; + inc(fevalstackheight,slots); + if (fevalstackheight>fmaxevalstackheight) then + fmaxevalstackheight:=fevalstackheight; + if cs_asm_regalloc in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew(' allocated '+tostr(slots)+', stack height = '+tostr(fevalstackheight)))); + end; + + procedure thlcgjvm.decstack(list: TAsmList;slots: longint); + begin + if slots=0 then + exit; + dec(fevalstackheight,slots); + if (fevalstackheight<0) and + not(cs_no_regalloc in current_settings.globalswitches) then + internalerror(2010120501); + if cs_asm_regalloc in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew(' freed '+tostr(slots)+', stack height = '+tostr(fevalstackheight)))); + end; + + class function thlcgjvm.def2regtyp(def: tdef): tregistertype; + begin + case def.typ of + { records (including files) and enums are implemented via classes } + recorddef, + filedef, + enumdef, + setdef: + result:=R_ADDRESSREGISTER; + { shortstrings are implemented via classes } + else if is_shortstring(def) or + { voiddef can only be typecasted into (implicit) pointers } + is_void(def) then + result:=R_ADDRESSREGISTER + else + result:=inherited; + end; + end; + + procedure thlcgjvm.a_load_const_cgpara(list: TAsmList; tosize: tdef; a: tcgint; const cgpara: TCGPara); + begin + tosize:=get_para_push_size(tosize); + if tosize=s8inttype then + a:=shortint(a) + else if tosize=s16inttype then + a:=smallint(a); + inherited a_load_const_cgpara(list, tosize, a, cgpara); + end; + + function thlcgjvm.a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara; + begin + result:=a_call_name_intern(list,pd,s,forceresdef,false); + end; + + function thlcgjvm.a_call_name_inherited(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara): tcgpara; + begin + result:=a_call_name_intern(list,pd,s,nil,true); + end; + + + function thlcgjvm.a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister; const paras: array of pcgpara): tcgpara; + begin + internalerror(2012042824); + result.init; + end; + + + procedure thlcgjvm.a_load_const_stack_intern(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType; legalize_const: boolean); + begin + if legalize_const and + (typ=R_INTREGISTER) and + (size.typ=orddef) then + begin + { uses specific byte/short array store instructions, and the Dalvik + VM does not like it if we store values outside the range } + case torddef(size).ordtype of + u8bit: + a:=shortint(a); + u16bit: + a:=smallint(a); + else + ; + end; + end; + a_load_const_stack(list,size,a,typ); + end; + + + procedure thlcgjvm.a_load_const_stack(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType); + const + int2opc: array[-1..5] of tasmop = (a_iconst_m1,a_iconst_0,a_iconst_1, + a_iconst_2,a_iconst_3,a_iconst_4,a_iconst_5); + begin + case typ of + R_INTREGISTER: + begin + case def_cgsize(size) of + OS_8,OS_16,OS_32, + OS_S8,OS_S16,OS_S32: + begin + { convert cardinals to longints } + a:=longint(a); + if (a>=-1) and + (a<=5) then + list.concat(taicpu.op_none(int2opc[a])) + else if (a>=low(shortint)) and + (a<=high(shortint)) then + list.concat(taicpu.op_const(a_bipush,a)) + else if (a>=low(smallint)) and + (a<=high(smallint)) then + list.concat(taicpu.op_const(a_sipush,a)) + else + list.concat(taicpu.op_const(a_ldc,a)); + { for android verifier } + if (size.typ=orddef) and + (torddef(size).ordtype=uwidechar) then + list.concat(taicpu.op_none(a_i2c)); + end; + OS_64,OS_S64: + begin + case a of + 0: + list.concat(taicpu.op_none(a_lconst_0)); + 1: + list.concat(taicpu.op_none(a_lconst_1)); + else + list.concat(taicpu.op_const(a_ldc2_w,a)); + end; + incstack(list,1); + end; + else + internalerror(2010110702); + end; + end; + R_ADDRESSREGISTER: + begin + if a<>0 then + internalerror(2010110701); + list.concat(taicpu.op_none(a_aconst_null)); + end; + else + internalerror(2010110703); + end; + incstack(list,1); + end; + + procedure thlcgjvm.a_load_stack_loc(list: TAsmList; size: tdef; const loc: tlocation); + begin + case loc.loc of + LOC_REGISTER,LOC_CREGISTER, + LOC_FPUREGISTER,LOC_CFPUREGISTER: + a_load_stack_reg(list,size,loc.register); + LOC_REFERENCE: + a_load_stack_ref(list,size,loc.reference,prepare_stack_for_ref(list,loc.reference,false)); + else + internalerror(2011020501); + end; + end; + + procedure thlcgjvm.a_load_loc_stack(list: TAsmList;size: tdef;const loc: tlocation); + begin + case loc.loc of + LOC_REGISTER,LOC_CREGISTER, + LOC_FPUREGISTER,LOC_CFPUREGISTER: + a_load_reg_stack(list,size,loc.register); + LOC_REFERENCE,LOC_CREFERENCE: + a_load_ref_stack(list,size,loc.reference,prepare_stack_for_ref(list,loc.reference,false)); + LOC_CONSTANT: + a_load_const_stack(list,size,loc.value,def2regtyp(size)); + else + internalerror(2011010401); + end; + end; + + procedure thlcgjvm.a_loadfpu_const_stack(list: TAsmList; size: tdef; a: double); + begin + case tfloatdef(size).floattype of + s32real: + begin + if a=0.0 then + list.concat(taicpu.op_none(a_fconst_0)) + else if a=1.0 then + list.concat(taicpu.op_none(a_fconst_1)) + else if a=2.0 then + list.concat(taicpu.op_none(a_fconst_2)) + else + list.concat(taicpu.op_single(a_ldc,a)); + incstack(list,1); + end; + s64real: + begin + if a=0.0 then + list.concat(taicpu.op_none(a_dconst_0)) + else if a=1.0 then + list.concat(taicpu.op_none(a_dconst_1)) + else + list.concat(taicpu.op_double(a_ldc2_w,a)); + incstack(list,2); + end + else + internalerror(2011010501); + end; + end; + + procedure thlcgjvm.a_op_stack(list: TAsmList; op: topcg; size: tdef; trunc32: boolean); + var + cgsize: tcgsize; + begin + if not trunc32 then + cgsize:=def_cgsize(size) + else + begin + resize_stack_int_val(list,u32inttype,s64inttype,false); + cgsize:=OS_S64; + end; + case cgsize of + OS_8,OS_S8, + OS_16,OS_S16, + OS_32,OS_S32: + begin + { not = xor 1 for boolean, xor -1 for the rest} + if op=OP_NOT then + begin + if not is_pasbool(size) then + a_load_const_stack(list,s32inttype,high(cardinal),R_INTREGISTER) + else + a_load_const_stack(list,size,1,R_INTREGISTER); + op:=OP_XOR; + end; + if TOpCG2IAsmOp[op]=A_None then + internalerror(2010120532); + list.concat(taicpu.op_none(TOpCG2IAsmOp[op])); + maybe_adjust_op_result(list,op,size); + if op<>OP_NEG then + decstack(list,1); + end; + OS_64,OS_S64: + begin + { unsigned 64 bit division must be done via a helper } + if op=OP_DIV then + internalerror(2010120530); + { not = xor 1 for boolean, xor -1 for the rest} + if op=OP_NOT then + begin + if not is_pasbool(size) then + a_load_const_stack(list,s64inttype,-1,R_INTREGISTER) + else + a_load_const_stack(list,s64inttype,1,R_INTREGISTER); + op:=OP_XOR; + end; + if TOpCG2LAsmOp[op]=A_None then + internalerror(2010120533); + list.concat(taicpu.op_none(TOpCG2LAsmOp[op])); + case op of + OP_NOT, + OP_NEG: + ; + { the second argument here is an int rather than a long } + OP_SHL,OP_SHR,OP_SAR: + decstack(list,1); + else + decstack(list,2); + end; + end; + else + internalerror(2010120531); + end; + if trunc32 then + begin + list.concat(taicpu.op_none(a_l2i)); + decstack(list,1); + end; + end; + + procedure thlcgjvm.a_op_const_stack(list: TAsmList;op: topcg;size: tdef;a: tcgint); + var + trunc32: boolean; + begin + maybepreparedivu32(list,op,size,trunc32); + case op of + OP_NEG,OP_NOT: + internalerror(2011010801); + OP_SHL,OP_SHR,OP_SAR: + { the second argument here is an int rather than a long } + a_load_const_stack(list,s32inttype,a,R_INTREGISTER); + else + a_load_const_stack(list,size,a,R_INTREGISTER); + end; + a_op_stack(list,op,size,trunc32); + end; + + procedure thlcgjvm.a_op_reg_stack(list: TAsmList; op: topcg; size: tdef; reg: tregister); + var + trunc32: boolean; + begin + maybepreparedivu32(list,op,size,trunc32); + case op of + OP_SHL,OP_SHR,OP_SAR: + if not is_64bitint(size) then + a_load_reg_stack(list,size,reg) + else + begin + { the second argument here is an int rather than a long } + if getsubreg(reg)=R_SUBQ then + internalerror(2011010802); + a_load_reg_stack(list,s32inttype,reg) + end + else + a_load_reg_stack(list,size,reg); + end; + a_op_stack(list,op,size,trunc32); + end; + + procedure thlcgjvm.a_op_ref_stack(list: TAsmList; op: topcg; size: tdef; const ref: treference); + var + trunc32: boolean; + begin + { ref must not be the stack top, because that may indicate an error + (it means that we will perform an operation of the stack top onto + itself, so that means the two values have been loaded manually prior + to calling this routine, instead of letting this routine load one of + them; if something like that is needed, call a_op_stack() directly) } + if ref.base=NR_EVAL_STACK_BASE then + internalerror(2010121102); + maybepreparedivu32(list,op,size,trunc32); + case op of + OP_SHL,OP_SHR,OP_SAR: + begin + if not is_64bitint(size) then + a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)) + else + a_load_ref_stack(list,s32inttype,ref,prepare_stack_for_ref(list,ref,false)); + end; + else + a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)); + end; + a_op_stack(list,op,size,trunc32); + end; + + procedure thlcgjvm.a_op_loc_stack(list: TAsmList; op: topcg; size: tdef; const loc: tlocation); + begin + case loc.loc of + LOC_REGISTER,LOC_CREGISTER: + a_op_reg_stack(list,op,size,loc.register); + LOC_REFERENCE,LOC_CREFERENCE: + a_op_ref_stack(list,op,size,loc.reference); + LOC_CONSTANT: + a_op_const_stack(list,op,size,loc.value); + else + internalerror(2011011415) + end; + end; + + procedure thlcgjvm.g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation); + begin + case fromloc.loc of + LOC_CREFERENCE, + LOC_REFERENCE: + begin + toloc:=fromloc; + if (fromloc.reference.base<>NR_NO) and + (fromloc.reference.base<>current_procinfo.framepointer) and + (fromloc.reference.base<>NR_STACK_POINTER_REG) then + g_allocload_reg_reg(list,voidpointertype,fromloc.reference.base,toloc.reference.base,R_ADDRESSREGISTER); + case fromloc.reference.arrayreftype of + art_indexreg: + begin + { all array indices in Java are 32 bit ints } + g_allocload_reg_reg(list,s32inttype,fromloc.reference.index,toloc.reference.index,R_INTREGISTER); + end; + art_indexref: + begin + { base register of the address of the index -> pointer } + if (fromloc.reference.indexbase<>NR_NO) and + (fromloc.reference.indexbase<>NR_STACK_POINTER_REG) then + g_allocload_reg_reg(list,voidpointertype,fromloc.reference.indexbase,toloc.reference.indexbase,R_ADDRESSREGISTER); + end; + else + ; + end; + end; + else + inherited; + end; + end; + + procedure thlcgjvm.g_newarray(list: TAsmList; arrdef: tdef; initdim: longint); + var + recref, + enuminitref: treference; + elemdef: tdef; + i: longint; + mangledname: string; + opc: tasmop; + primitivetype: boolean; + begin + elemdef:=arrdef; + if initdim>1 then + begin + { multianewarray typedesc ndim } + { todo: WASM + list.concat(taicpu.op_sym_const(a_multianewarray, + current_asmdata.RefAsmSymbol(jvmarrtype(elemdef,primitivetype),AT_METADATA),initdim)); + } + { has to be a multi-dimensional array type } + if primitivetype then + internalerror(2011012207); + end + else + begin + { for primitive types: + newarray typedesc + for reference types: + anewarray typedesc + } + { get the type of the elements of the array we are creating } + elemdef:=tarraydef(arrdef).elementdef; + { todo: WASM + mangledname:=jvmarrtype(elemdef,primitivetype); + } + if primitivetype then + opc:=a_newarray + else + opc:=a_anewarray; + list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(mangledname,AT_METADATA))); + end; + { all dimensions are removed from the stack, an array reference is + added } + decstack(list,initdim-1); + { in case of an array of records, sets or shortstrings, initialise } + elemdef:=tarraydef(arrdef).elementdef; + for i:=1 to pred(initdim) do + elemdef:=tarraydef(elemdef).elementdef; + if (elemdef.typ in [recorddef,setdef]) or + ((elemdef.typ=enumdef) and + get_enum_init_val_ref(elemdef,enuminitref)) or + is_shortstring(elemdef) or + ((elemdef.typ=procvardef) and + not tprocvardef(elemdef).is_addressonly) or + is_ansistring(elemdef) or + is_wide_or_unicode_string(elemdef) or + is_dynamic_array(elemdef) then + begin + { duplicate array instance } + list.concat(taicpu.op_none(a_dup)); + incstack(list,1); + a_load_const_stack(list,s32inttype,initdim-1,R_INTREGISTER); + case elemdef.typ of + arraydef: + g_call_system_proc(list,'fpc_initialize_array_dynarr',[],nil); + recorddef,setdef,procvardef: + begin + tg.gethltemp(list,elemdef,elemdef.size,tt_persistent,recref); + a_load_ref_stack(list,elemdef,recref,prepare_stack_for_ref(list,recref,false)); + case elemdef.typ of + recorddef: + g_call_system_proc(list,'fpc_initialize_array_record',[],nil); + setdef: + begin + if tsetdef(elemdef).elementdef.typ=enumdef then + g_call_system_proc(list,'fpc_initialize_array_enumset',[],nil) + else + g_call_system_proc(list,'fpc_initialize_array_bitset',[],nil) + end; + procvardef: + g_call_system_proc(list,'fpc_initialize_array_procvar',[],nil); + else + internalerror(2019051025); + end; + tg.ungettemp(list,recref); + end; + enumdef: + begin + a_load_ref_stack(list,java_jlobject,enuminitref,prepare_stack_for_ref(list,enuminitref,false)); + g_call_system_proc(list,'fpc_initialize_array_object',[],nil); + end; + stringdef: + begin + case tstringdef(elemdef).stringtype of + st_shortstring: + begin + a_load_const_stack_intern(list,u8inttype,tstringdef(elemdef).len,R_INTREGISTER,true); + g_call_system_proc(list,'fpc_initialize_array_shortstring',[],nil); + end; + st_ansistring: + g_call_system_proc(list,'fpc_initialize_array_ansistring',[],nil); + st_unicodestring, + st_widestring: + g_call_system_proc(list,'fpc_initialize_array_unicodestring',[],nil); + else + internalerror(2011081801); + end; + end; + else + internalerror(2011081801); + end; + end; + end; + + procedure thlcgjvm.g_getarraylen(list: TAsmList; const arrloc: tlocation); + var + nillab,endlab: tasmlabel; + begin + { inline because we have to use the arraylength opcode, which + cannot be represented directly in Pascal. Even though the JVM + supports allocated arrays with length=0, we still also have to + check for nil pointers because even if FPC always generates + allocated empty arrays under all circumstances, external Java + code could pass in nil pointers. + + Note that this means that assigned(arr) can be different from + length(arr)<>0 for dynamic arrays when targeting the JVM. + } + current_asmdata.getjumplabel(nillab); + current_asmdata.getjumplabel(endlab); + + { if assigned(arr) ... } + a_load_loc_stack(list,java_jlobject,arrloc); + list.concat(taicpu.op_none(a_dup)); + incstack(list,1); + list.concat(taicpu.op_sym(a_ifnull,nillab)); + decstack(list,1); + + { ... then result:=arraylength(arr) ... } + list.concat(taicpu.op_none(a_arraylength)); + a_jmp_always(list,endlab); + + { ... else result:=0 } + a_label(list,nillab); + list.concat(taicpu.op_none(a_pop)); + decstack(list,1); + list.concat(taicpu.op_none(a_iconst_0)); + incstack(list,1); + + a_label(list,endlab); + end; + + procedure thlcgjvm.a_cmp_stack_label(list: TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel); + const + opcmp2icmp: array[topcmp] of tasmop = (A_None, + a_if_icmpeq,a_if_icmpgt,a_if_icmplt,a_if_icmpge,a_if_icmple, + a_if_icmpne,a_if_icmple,a_if_icmplt,a_if_icmpge,a_if_icmpgt); + var + cgsize: tcgsize; + begin + case def2regtyp(size) of + R_INTREGISTER: + begin + cgsize:=def_cgsize(size); + case cgsize of + OS_S8,OS_8, + OS_16,OS_S16, + OS_S32,OS_32: + begin + list.concat(taicpu.op_sym(opcmp2icmp[cmp_op],lab)); + decstack(list,2); + end; + OS_64,OS_S64: + begin + list.concat(taicpu.op_none(a_lcmp)); + decstack(list,3); + list.concat(taicpu.op_sym(opcmp2if[cmp_op],lab)); + decstack(list,1); + end; + else + internalerror(2010120538); + end; + end; + R_ADDRESSREGISTER: + begin + case cmp_op of + OC_EQ: + list.concat(taicpu.op_sym(a_if_acmpeq,lab)); + OC_NE: + list.concat(taicpu.op_sym(a_if_acmpne,lab)); + else + internalerror(2010120537); + end; + decstack(list,2); + end; + else + internalerror(2010120538); + end; + end; + + procedure thlcgjvm.maybe_adjust_cmp_stackval(list: TAsmlist; size: tdef; cmp_op: topcmp); + begin + { use cmp_op because eventually that's what indicates the + signed/unsigned character of the operation, not the size... } + if (cmp_op in [OC_EQ,OC_NE,OC_LT,OC_LTE,OC_GT,OC_GTE]) or + (def2regtyp(size)<>R_INTREGISTER) then + exit; + { http://stackoverflow.com/questions/4068973/c-performing-signed-comparison-in-unsigned-variables-without-casting } + case def_cgsize(size) of + OS_32,OS_S32: + a_op_const_stack(list,OP_XOR,size,cardinal($80000000)); + OS_64,OS_S64: + a_op_const_stack(list,OP_XOR,size,tcgint($8000000000000000)); + else + ; + end; + end; + + function thlcgjvm.maybe_adjust_cmp_constval(size: tdef; cmp_op: topcmp; a: tcgint): tcgint; + begin + result:=a; + { use cmp_op because eventually that's what indicates the + signed/unsigned character of the operation, not the size... } + if (cmp_op in [OC_EQ,OC_NE,OC_LT,OC_LTE,OC_GT,OC_GTE]) or + (def2regtyp(size)<>R_INTREGISTER) then + exit; + case def_cgsize(size) of + OS_32,OS_S32: + result:=a xor cardinal($80000000); + OS_64,OS_S64: +{$push}{$r-} + result:=a xor tcgint($8000000000000000); +{$pop} + else + ; + end; + end; + + procedure thlcgjvm.maybe_adjust_op_result(list: TAsmList; op: TOpCg; size: tdef); + const + overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NOT,OP_NEG]; + begin + if ((op in overflowops) or + (current_settings.cputype=cpu_dalvik)) and + (def_cgsize(size) in [OS_8,OS_S8,OS_16,OS_S16]) then + resize_stack_int_val(list,s32inttype,size,false); + end; + + procedure thlcgjvm.gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara); + begin + { constructors don't return anything in Java } + if pd.proctypeoption=potype_constructor then + exit; + { must return a value of the correct type on the evaluation stack } + case def2regtyp(resdef) of + R_INTREGISTER, + R_ADDRESSREGISTER: + a_load_const_cgpara(list,resdef,0,resloc); + R_FPUREGISTER: + case tfloatdef(resdef).floattype of + s32real: + begin + list.concat(taicpu.op_none(a_fconst_0)); + incstack(list,1); + end; + s64real: + begin + list.concat(taicpu.op_none(a_dconst_0)); + incstack(list,2); + end; + else + internalerror(2011010302); + end + else + internalerror(2011010301); + end; + end; + + + procedure thlcgjvm.g_copyvalueparas(p: TObject; arg: pointer); + var + list: tasmlist; + tmpref: treference; + begin + { zero-extend < 32 bit primitive types (FPC can zero-extend when calling, + but that doesn't help when we're called from Java code or indirectly + as a procvar -- exceptions: widechar (Java-specific type) and ordinal + types whose upper bound does not set the sign bit } + if (tsym(p).typ=paravarsym) and + (tparavarsym(p).varspez in [vs_value,vs_const]) and + (tparavarsym(p).vardef.typ=orddef) and + not is_pasbool(tparavarsym(p).vardef) and + not is_widechar(tparavarsym(p).vardef) and + (tparavarsym(p).vardef.size<4) and + not is_signed(tparavarsym(p).vardef) and + (torddef(tparavarsym(p).vardef).high>=(1 shl (tparavarsym(p).vardef.size*8-1))) then + begin + list:=TAsmList(arg); + { store value in new location to keep Android verifier happy } + tg.gethltemp(list,tparavarsym(p).vardef,tparavarsym(p).vardef.size,tt_persistent,tmpref); + a_load_loc_stack(list,tparavarsym(p).vardef,tparavarsym(p).initialloc); + a_op_const_stack(list,OP_AND,tparavarsym(p).vardef,(1 shl (tparavarsym(p).vardef.size*8))-1); + a_load_stack_ref(list,tparavarsym(p).vardef,tmpref,prepare_stack_for_ref(list,tmpref,false)); + location_reset_ref(tparavarsym(p).localloc,LOC_REFERENCE,def_cgsize(tparavarsym(p).vardef),4,tmpref.volatility); + tparavarsym(p).localloc.reference:=tmpref; + end; + + inherited g_copyvalueparas(p, arg); + end; + + + procedure thlcgjvm.inittempvariables(list: TAsmList); + begin + { these are automatically initialised when allocated if necessary } + end; + + + function thlcgjvm.g_call_system_proc_intern(list: TAsmList; pd: tprocdef; const paras: array of pcgpara; forceresdef: tdef): tcgpara; + begin + result:=inherited; + pd.init_paraloc_info(callerside); + g_adjust_stack_after_call(list,pd,pd.callerargareasize,forceresdef); + end; + + + function thlcgjvm.prepare_stack_for_ref(list: TAsmList; const ref: treference; dup: boolean): longint; + var + href: treference; + begin + result:=0; + { fake location that indicates the value is already on the stack? } + if (ref.base=NR_EVAL_STACK_BASE) then + exit; + if ref.arrayreftype=art_none then + begin + { non-array accesses cannot have an index reg } + if ref.index<>NR_NO then + internalerror(2010120509); + if (ref.base<>NR_NO) then + begin + if (ref.base<>NR_STACK_POINTER_REG) then + begin + { regular field -> load self on the stack } + a_load_reg_stack(list,voidpointertype,ref.base); + if dup then + begin + list.concat(taicpu.op_none(a_dup)); + incstack(list,1); + end; + { field name/type encoded in symbol, no index/offset } + if not assigned(ref.symbol) or + (ref.offset<>0) then + internalerror(2010120524); + result:=1; + end + else + begin + { local variable -> offset encoded in opcode and nothing to + do here, except for checking that it's a valid reference } + if assigned(ref.symbol) then + internalerror(2010120523); + end; + end + else + begin + { static field -> nothing to do here, except for validity check } + if not assigned(ref.symbol) or + (ref.offset<>0) then + internalerror(2010120525); + end; + end + else + begin + { arrays have implicit dereference -> pointer to array must have been + loaded into base reg } + if (ref.base=NR_NO) or + (ref.base=NR_STACK_POINTER_REG) then + internalerror(2010120511); + if assigned(ref.symbol) then + internalerror(2010120512); + + { stack: ... -> ..., arrayref, index } + { load array base address } + a_load_reg_stack(list,voidpointertype,ref.base); + { index can either be in a register, or located in a simple memory + location (since we have to load it anyway) } + case ref.arrayreftype of + art_indexreg: + begin + if ref.index=NR_NO then + internalerror(2010120513); + { all array indices in Java are 32 bit ints } + a_load_reg_stack(list,s32inttype,ref.index); + end; + art_indexref: + begin + cgutils.reference_reset_base(href,ref.indexbase,ref.indexoffset,ref.temppos,4,ref.volatility); + href.symbol:=ref.indexsymbol; + a_load_ref_stack(list,s32inttype,href,prepare_stack_for_ref(list,href,false)); + end; + art_indexconst: + begin + a_load_const_stack(list,s32inttype,ref.indexoffset,R_INTREGISTER); + end; + else + internalerror(2011012001); + end; + { adjustment of the index } + if ref.offset<>0 then + a_op_const_stack(list,OP_ADD,s32inttype,ref.offset); + if dup then + begin + list.concat(taicpu.op_none(a_dup2)); + incstack(list,2); + end; + result:=2; + end; + end; + + procedure thlcgjvm.a_load_const_reg(list: TAsmList; tosize: tdef; a: tcgint; register: tregister); + begin + a_load_const_stack(list,tosize,a,def2regtyp(tosize)); + a_load_stack_reg(list,tosize,register); + end; + + procedure thlcgjvm.a_load_const_ref(list: TAsmList; tosize: tdef; a: tcgint; const ref: treference); + var + extra_slots: longint; + begin + extra_slots:=prepare_stack_for_ref(list,ref,false); + a_load_const_stack_intern(list,tosize,a,def2regtyp(tosize),(ref.arrayreftype<>art_none) or assigned(ref.symbol)); + a_load_stack_ref(list,tosize,ref,extra_slots); + end; + + procedure thlcgjvm.a_load_reg_ref(list: TAsmList; fromsize, tosize: tdef; register: tregister; const ref: treference); + var + extra_slots: longint; + begin + extra_slots:=prepare_stack_for_ref(list,ref,false); + a_load_reg_stack(list,fromsize,register); + if def2regtyp(fromsize)=R_INTREGISTER then + resize_stack_int_val(list,fromsize,tosize,(ref.arrayreftype<>art_none) or assigned(ref.symbol)); + a_load_stack_ref(list,tosize,ref,extra_slots); + end; + + procedure thlcgjvm.a_load_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); + begin + a_load_reg_stack(list,fromsize,reg1); + if def2regtyp(fromsize)=R_INTREGISTER then + resize_stack_int_val(list,fromsize,tosize,false); + a_load_stack_reg(list,tosize,reg2); + end; + + procedure thlcgjvm.a_load_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; register: tregister); + var + extra_slots: longint; + begin + extra_slots:=prepare_stack_for_ref(list,ref,false); + a_load_ref_stack(list,fromsize,ref,extra_slots); + + if def2regtyp(fromsize)=R_INTREGISTER then + resize_stack_int_val(list,fromsize,tosize,false); + a_load_stack_reg(list,tosize,register); + end; + + procedure thlcgjvm.a_load_ref_ref(list: TAsmList; fromsize, tosize: tdef; const sref: treference; const dref: treference); + var + extra_sslots, + extra_dslots: longint; + begin + { make sure the destination reference is on top, since in the end the + order has to be "destref, value" -> first create "destref, sourceref" } + extra_dslots:=prepare_stack_for_ref(list,dref,false); + extra_sslots:=prepare_stack_for_ref(list,sref,false); + a_load_ref_stack(list,fromsize,sref,extra_sslots); + if def2regtyp(fromsize)=R_INTREGISTER then + resize_stack_int_val(list,fromsize,tosize,(dref.arrayreftype<>art_none) or assigned(dref.symbol)); + a_load_stack_ref(list,tosize,dref,extra_dslots); + end; + + procedure thlcgjvm.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister); + begin + { only allowed for types that are not implicit pointers in Pascal (in + that case, ref contains a pointer to the actual data and we simply + return that pointer) } + if not wasmimplicitpointertype(fromsize) then + internalerror(2010120534); + a_load_ref_reg(list,java_jlobject,java_jlobject,ref,r); + end; + + procedure thlcgjvm.a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; reg: TRegister); + begin + a_op_const_reg_reg(list,op,size,a,reg,reg); + end; + + procedure thlcgjvm.a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister); + begin + a_load_reg_stack(list,size,src); + a_op_const_stack(list,op,size,a); + a_load_stack_reg(list,size,dst); + end; + + procedure thlcgjvm.a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; const ref: TReference); + var + extra_slots: longint; + begin + extra_slots:=prepare_stack_for_ref(list,ref,true); + { TODO, here or in peepholeopt: use iinc when possible } + a_load_ref_stack(list,size,ref,extra_slots); + a_op_const_stack(list,op,size,a); + { for android verifier } + if (def2regtyp(size)=R_INTREGISTER) and + ((ref.arrayreftype<>art_none) or + assigned(ref.symbol)) then + resize_stack_int_val(list,size,size,true); + a_load_stack_ref(list,size,ref,extra_slots); + end; + + procedure thlcgjvm.a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); + begin + if not(op in [OP_NOT,OP_NEG]) then + a_load_reg_stack(list,size,reg); + a_op_ref_stack(list,op,size,ref); + a_load_stack_reg(list,size,reg); + end; + + procedure thlcgjvm.a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); + begin + if not(op in [OP_NOT,OP_NEG]) then + a_load_reg_stack(list,size,src2); + a_op_reg_stack(list,op,size,src1); + a_load_stack_reg(list,size,dst); + end; + + procedure thlcgjvm.a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); + begin + a_op_reg_reg_reg(list,op,size,reg1,reg2,reg2); + end; + + procedure thlcgjvm.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister; setflags: boolean; var ovloc: tlocation); + var + tmpreg: tregister; + begin + if not setflags then + begin + inherited; + exit; + end; + tmpreg:=getintregister(list,size); + a_load_const_reg(list,size,a,tmpreg); + a_op_reg_reg_reg_checkoverflow(list,op,size,tmpreg,src,dst,true,ovloc); + end; + + procedure thlcgjvm.a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister; setflags: boolean; var ovloc: tlocation); + var + orgsrc1, orgsrc2: tregister; + docheck: boolean; + lab: tasmlabel; + begin + if not setflags then + begin + inherited; + exit; + end; + { anything else cannot overflow } + docheck:=size.size in [4,8]; + if docheck then + begin + orgsrc1:=src1; + orgsrc2:=src2; + if src1=dst then + begin + orgsrc1:=getintregister(list,size); + a_load_reg_reg(list,size,size,src1,orgsrc1); + end; + if src2=dst then + begin + orgsrc2:=getintregister(list,size); + a_load_reg_reg(list,size,size,src2,orgsrc2); + end; + end; + a_op_reg_reg_reg(list,op,size,src1,src2,dst); + if docheck then + begin + { * signed overflow for addition iff + - src1 and src2 are negative and result is positive (excep in case of + subtraction, then sign of src1 has to be inverted) + - src1 and src2 are positive and result is negative + -> Simplified boolean equivalent (in terms of sign bits): + not(src1 xor src2) and (src1 xor dst) + + for subtraction, multiplication: invert src1 sign bit + for division: handle separately (div by zero, low(inttype) div -1), + not supported by this code + + * unsigned overflow iff carry out, aka dst < src1 or dst < src2 + } + location_reset(ovloc,LOC_REGISTER,OS_S32); + { not pasbool8, because then we'd still have to convert the integer to + a boolean via branches for Dalvik} + ovloc.register:=getintregister(list,s32inttype); + if not ((size.typ=pointerdef) or + ((size.typ=orddef) and + (torddef(size).ordtype in [u64bit,u16bit,u32bit,u8bit,uchar, + pasbool1,pasbool8,pasbool16,pasbool32,pasbool64]))) then + begin + a_load_reg_stack(list,size,src1); + if op in [OP_SUB,OP_IMUL] then + a_op_stack(list,OP_NOT,size,false); + a_op_reg_stack(list,OP_XOR,size,src2); + a_op_stack(list,OP_NOT,size,false); + a_load_reg_stack(list,size,src1); + a_op_reg_stack(list,OP_XOR,size,dst); + a_op_stack(list,OP_AND,size,false); + a_op_const_stack(list,OP_SHR,size,(size.size*8)-1); + if size.size=8 then + begin + list.concat(taicpu.op_none(a_l2i)); + decstack(list,1); + end; + end + else + begin + a_load_const_stack(list,s32inttype,0,R_INTREGISTER); + current_asmdata.getjumplabel(lab); + { can be optimized by removing duplicate xor'ing to convert dst from + signed to unsigned quadrant } + a_cmp_reg_reg_label(list,size,OC_B,dst,src1,lab); + a_cmp_reg_reg_label(list,size,OC_B,dst,src2,lab); + a_op_const_stack(list,OP_XOR,s32inttype,1); + a_label(list,lab); + end; + a_load_stack_reg(list,s32inttype,ovloc.register); + end + else + ovloc.loc:=LOC_VOID; + end; + + procedure thlcgjvm.a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; const ref: treference; l: tasmlabel); + begin + if ref.base<>NR_EVAL_STACK_BASE then + a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)); + maybe_adjust_cmp_stackval(list,size,cmp_op); + a_load_const_stack(list,size,maybe_adjust_cmp_constval(size,cmp_op,a),def2regtyp(size)); + a_cmp_stack_label(list,size,cmp_op,l); + end; + + procedure thlcgjvm.a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel); + begin + a_load_reg_stack(list,size,reg); + maybe_adjust_cmp_stackval(list,size,cmp_op); + a_load_const_stack(list,size,maybe_adjust_cmp_constval(size,cmp_op,a),def2regtyp(size)); + a_cmp_stack_label(list,size,cmp_op,l); + end; + + procedure thlcgjvm.a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel); + begin + a_load_reg_stack(list,size,reg); + maybe_adjust_cmp_stackval(list,size,cmp_op); + if ref.base<>NR_EVAL_STACK_BASE then + a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)) + else + list.concat(taicpu.op_none(a_swap)); + maybe_adjust_cmp_stackval(list,size,cmp_op); + a_cmp_stack_label(list,size,cmp_op,l); + end; + + procedure thlcgjvm.a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel); + begin + if ref.base<>NR_EVAL_STACK_BASE then + a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false)); + maybe_adjust_cmp_stackval(list,size,cmp_op); + a_load_reg_stack(list,size,reg); + maybe_adjust_cmp_stackval(list,size,cmp_op); + a_cmp_stack_label(list,size,cmp_op,l); + end; + + procedure thlcgjvm.a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); + begin + a_load_reg_stack(list,size,reg2); + maybe_adjust_cmp_stackval(list,size,cmp_op); + a_load_reg_stack(list,size,reg1); + maybe_adjust_cmp_stackval(list,size,cmp_op); + a_cmp_stack_label(list,size,cmp_op,l); + end; + + procedure thlcgjvm.a_jmp_always(list: TAsmList; l: tasmlabel); + begin + list.concat(taicpu.op_sym(a_goto,current_asmdata.RefAsmSymbol(l.name,AT_METADATA))); + end; + + procedure thlcgjvm.concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference); + var + procname: string; + eledef: tdef; + ndim: longint; + adddefaultlenparas: boolean; + begin + { load copy helper parameters on the stack } + a_load_ref_stack(list,java_jlobject,source,prepare_stack_for_ref(list,source,false)); + a_load_ref_stack(list,java_jlobject,dest,prepare_stack_for_ref(list,dest,false)); + { call copy helper } + eledef:=tarraydef(size).elementdef; + ndim:=1; + adddefaultlenparas:=true; + case eledef.typ of + orddef: + begin + case torddef(eledef).ordtype of + pasbool1,pasbool8,s8bit,u8bit,bool8bit,uchar, + s16bit,u16bit,bool16bit,pasbool16, + uwidechar, + s32bit,u32bit,bool32bit,pasbool32, + s64bit,u64bit,bool64bit,pasbool64,scurrency: + procname:='FPC_COPY_SHALLOW_ARRAY' + else + internalerror(2011020504); + end; + end; + arraydef: + begin + { call fpc_setlength_dynarr_multidim with deepcopy=true, and extra + parameters } + while (eledef.typ=arraydef) and + not is_dynamic_array(eledef) do + begin + eledef:=tarraydef(eledef).elementdef; + inc(ndim) + end; + if (ndim=1) then + procname:='FPC_COPY_SHALLOW_ARRAY' + else + begin + { deepcopy=true } + a_load_const_stack(list,pasbool1type,1,R_INTREGISTER); + { ndim } + a_load_const_stack(list,s32inttype,ndim,R_INTREGISTER); + { eletype } + { todo: WASM + a_load_const_stack(list,cwidechartype,ord(jvmarrtype_setlength(eledef)),R_INTREGISTER); + } + adddefaultlenparas:=false; + procname:='FPC_SETLENGTH_DYNARR_MULTIDIM'; + end; + end; + recorddef: + procname:='FPC_COPY_JRECORD_ARRAY'; + procvardef: + if tprocvardef(eledef).is_addressonly then + procname:='FPC_COPY_SHALLOW_ARRAY' + else + procname:='FPC_COPY_JPROCVAR_ARRAY'; + setdef: + if tsetdef(eledef).elementdef.typ=enumdef then + procname:='FPC_COPY_JENUMSET_ARRAY' + else + procname:='FPC_COPY_JBITSET_ARRAY'; + floatdef: + procname:='FPC_COPY_SHALLOW_ARRAY'; + stringdef: + if is_shortstring(eledef) then + procname:='FPC_COPY_JSHORTSTRING_ARRAY' + else + procname:='FPC_COPY_SHALLOW_ARRAY'; + variantdef: + begin +{$ifndef nounsupported} + procname:='FPC_COPY_SHALLOW_ARRAY'; +{$else} + { todo: make a deep copy via clone... } + internalerror(2011020505); +{$endif} + end; + else + procname:='FPC_COPY_SHALLOW_ARRAY'; + end; + if adddefaultlenparas then + begin + { -1, -1 means "copy entire array" } + a_load_const_stack(list,s32inttype,-1,R_INTREGISTER); + a_load_const_stack(list,s32inttype,-1,R_INTREGISTER); + end; + g_call_system_proc(list,procname,[],nil); + if ndim<>1 then + begin + { pop return value, must be the same as dest } + list.concat(taicpu.op_none(a_pop)); + decstack(list,1); + end; + end; + + procedure thlcgjvm.concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference); + var + srsym: tsym; + pd: tprocdef; + begin + { self } + a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false)); + { result } + a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false)); + { call fpcDeepCopy helper } + srsym:=search_struct_member(tabstractrecorddef(size),'FPCDEEPCOPY'); + if not assigned(srsym) or + (srsym.typ<>procsym) then + Message1(cg_f_unknown_compilerproc,size.typename+'.fpcDeepCopy'); + pd:=tprocdef(tprocsym(srsym).procdeflist[0]); + a_call_name(list,pd,pd.mangledname,[],nil,false); + { both parameters are removed, no function result } + decstack(list,2); + end; + + + procedure thlcgjvm.concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference); + begin + a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false)); + a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false)); + { call set copy helper } + if tsetdef(size).elementdef.typ=enumdef then + g_call_system_proc(list,'fpc_enumset_copy',[],nil) + else + g_call_system_proc(list,'fpc_bitset_copy',[],nil); + end; + + + procedure thlcgjvm.concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference); + var + srsym: tsym; + pd: tprocdef; + begin + { self } + a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false)); + { result } + a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false)); + { call fpcDeepCopy helper } + srsym:=search_struct_member(java_shortstring,'FPCDEEPCOPY'); + if not assigned(srsym) or + (srsym.typ<>procsym) then + Message1(cg_f_unknown_compilerproc,'ShortstringClass.FpcDeepCopy'); + pd:=tprocdef(tprocsym(srsym).procdeflist[0]); + a_call_name(list,pd,pd.mangledname,[],nil,false); + { both parameters are removed, no function result } + decstack(list,2); + end; + + + procedure thlcgjvm.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference); + var + handled: boolean; + begin + handled:=false; + case size.typ of + arraydef: + begin + if not is_dynamic_array(size) then + begin + concatcopy_normal_array(list,size,source,dest); + handled:=true; + end; + end; + recorddef: + begin + concatcopy_record(list,size,source,dest); + handled:=true; + end; + setdef: + begin + concatcopy_set(list,size,source,dest); + handled:=true; + end; + stringdef: + begin + if is_shortstring(size) then + begin + concatcopy_shortstring(list,size,source,dest); + handled:=true; + end; + end; + procvardef: + begin + if not tprocvardef(size).is_addressonly then + begin + concatcopy_record(list,tcpuprocvardef(size).classdef,source,dest); + handled:=true; + end; + end; + else + ; + end; + if not handled then + inherited; + end; + + procedure thlcgjvm.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef); + begin + concatcopy_shortstring(list,strdef,source,dest); + end; + + procedure thlcgjvm.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference); + var + dstack_slots: longint; + begin + dstack_slots:=prepare_stack_for_ref(list,ref2,false); + a_load_ref_stack(list,fromsize,ref1,prepare_stack_for_ref(list,ref1,false)); + resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize)); + a_load_stack_ref(list,tosize,ref2,dstack_slots); + end; + + procedure thlcgjvm.a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); + begin + a_load_ref_stack(list,fromsize,ref,prepare_stack_for_ref(list,ref,false)); + resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize)); + a_load_stack_reg(list,tosize,reg); + end; + + procedure thlcgjvm.a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); + var + dstack_slots: longint; + begin + dstack_slots:=prepare_stack_for_ref(list,ref,false); + a_load_reg_stack(list,fromsize,reg); + resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize)); + a_load_stack_ref(list,tosize,ref,dstack_slots); + end; + + procedure thlcgjvm.a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); + begin + a_load_reg_stack(list,fromsize,reg1); + resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize)); + a_load_stack_reg(list,tosize,reg2); + end; + + procedure thlcgjvm.g_proc_entry(list: TAsmList; localsize: longint; nostackframe: boolean); + begin + { the localsize is based on tg.lasttemp -> already in terms of stack + slots rather than bytes } + list.concat(tai_directive.Create(asd_jlimit,'locals '+tostr(localsize))); + { we insert the unit initialisation code afterwards in the proginit code, + and it uses one stack slot } + if (current_procinfo.procdef.proctypeoption=potype_proginit) then + fmaxevalstackheight:=max(1,fmaxevalstackheight); + list.concat(tai_directive.Create(asd_jlimit,'stack '+tostr(fmaxevalstackheight))); + end; + + procedure thlcgjvm.g_proc_exit(list: TAsmList; parasize: longint; nostackframe: boolean); + var + retdef: tdef; + opc: tasmop; + begin + if current_procinfo.procdef.proctypeoption in [potype_constructor,potype_class_constructor] then + retdef:=voidtype + else + retdef:=current_procinfo.procdef.returndef; + case retdef.typ of + orddef: + case torddef(retdef).ordtype of + uvoid: + opc:=a_return; + s64bit, + u64bit, + scurrency: + opc:=a_lreturn; + else + opc:=a_ireturn; + end; + setdef: + opc:=a_areturn; + floatdef: + case tfloatdef(retdef).floattype of + s32real: + opc:=a_freturn; + s64real: + opc:=a_dreturn; + else + internalerror(2011010213); + end; + else + opc:=a_areturn; + end; + list.concat(taicpu.op_none(opc)); + end; + + procedure thlcgjvm.gen_load_return_value(list: TAsmList); + begin + { constructors don't return anything in the jvm } + if current_procinfo.procdef.proctypeoption in [potype_constructor,potype_class_constructor] then + exit; + inherited gen_load_return_value(list); + end; + + procedure thlcgjvm.record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList); + begin + { add something to the al_procedures list as well, because if all al_* + lists are empty, the assembler writer isn't called } + if not code.empty and + current_asmdata.asmlists[al_procedures].empty then + current_asmdata.asmlists[al_procedures].concat(tai_align.Create(4)); + tcpuprocdef(pd).exprasmlist:=TAsmList.create; + tcpuprocdef(pd).exprasmlist.concatlist(code); + if assigned(data) and + not data.empty then + internalerror(2010122801); + end; + + procedure thlcgjvm.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference); + begin + // do nothing + end; + + procedure thlcgjvm.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); + var + normaldim: longint; + eleref: treference; + begin + { only in case of initialisation, we have to set all elements to "empty" } + if name<>'fpc_initialize_array' then + exit; + { put array on the stack } + a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false)); + { in case it's an open array whose elements are regular arrays, put the + dimension of the regular arrays on the stack (otherwise pass 0) } + normaldim:=0; + while (t.typ=arraydef) and + not is_dynamic_array(t) do + begin + inc(normaldim); + t:=tarraydef(t).elementdef; + end; + a_load_const_stack(list,s32inttype,normaldim,R_INTREGISTER); + { highloc is invalid, the length is part of the array in Java } + if is_wide_or_unicode_string(t) then + g_call_system_proc(list,'fpc_initialize_array_unicodestring',[],nil) + else if is_ansistring(t) then + g_call_system_proc(list,'fpc_initialize_array_ansistring',[],nil) + else if is_dynamic_array(t) then + g_call_system_proc(list,'fpc_initialize_array_dynarr',[],nil) + else if is_record(t) or + (t.typ=setdef) then + begin + tg.gethltemp(list,t,t.size,tt_persistent,eleref); + a_load_ref_stack(list,t,eleref,prepare_stack_for_ref(list,eleref,false)); + if is_record(t) then + g_call_system_proc(list,'fpc_initialize_array_record',[],nil) + else if tsetdef(t).elementdef.typ=enumdef then + g_call_system_proc(list,'fpc_initialize_array_enumset',[],nil) + else + g_call_system_proc(list,'fpc_initialize_array_bitset',[],nil); + tg.ungettemp(list,eleref); + end + else if (t.typ=enumdef) then + begin + if get_enum_init_val_ref(t,eleref) then + begin + a_load_ref_stack(list,java_jlobject,eleref,prepare_stack_for_ref(list,eleref,false)); + g_call_system_proc(list,'fpc_initialize_array_object',[],nil); + end; + end + else + internalerror(2011031901); + end; + + procedure thlcgjvm.g_initialize(list: TAsmList; t: tdef; const ref: treference); + var + dummyloc: tlocation; + sym: tsym; + pd: tprocdef; + begin + if (t.typ=arraydef) and + not is_dynamic_array(t) then + begin + dummyloc.loc:=LOC_INVALID; + g_array_rtti_helper(list,tarraydef(t).elementdef,ref,dummyloc,'fpc_initialize_array') + end + else if is_record(t) then + begin + { call the fpcInitializeRec method } + sym:=tsym(trecorddef(t).symtable.find('FPCINITIALIZEREC')); + if assigned(sym) and + (sym.typ=procsym) then + begin + if tprocsym(sym).procdeflist.Count<>1 then + internalerror(2011071713); + pd:=tprocdef(tprocsym(sym).procdeflist[0]); + end + else + internalerror(2013113008); + a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false)); + a_call_name(list,pd,pd.mangledname,[],nil,false); + { parameter removed, no result } + decstack(list,1); + end + else + a_load_const_ref(list,t,0,ref); + end; + + procedure thlcgjvm.g_finalize(list: TAsmList; t: tdef; const ref: treference); + begin + // do nothing + end; + + procedure thlcgjvm.g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); + begin + { not possible, need the original operands } + internalerror(2012102101); + end; + + procedure thlcgjvm.g_overflowCheck_loc(List: TAsmList; const Loc: TLocation; def: TDef; var ovloc: tlocation); + var + hl : tasmlabel; + begin + if not(cs_check_overflow in current_settings.localswitches) then + exit; + current_asmdata.getjumplabel(hl); + a_cmp_const_loc_label(list,s32inttype,OC_EQ,0,ovloc,hl); + g_call_system_proc(list,'fpc_overflow',[],nil); + a_label(list,hl); + end; + + procedure thlcgjvm.location_get_data_ref(list: TAsmList; def: tdef; const l: tlocation; var ref: treference; loadref: boolean; alignment: longint); + var + tmploc: tlocation; + begin + { This routine is a combination of a generalised a_loadaddr_ref_reg() + that also works for addresses in registers (in case loadref is false) + and of a_load_ref_reg (in case loadref is true). It is used for + a) getting the address of managed var/out parameters + b) getting to the actual data of value types that are passed by + reference by the compiler (and then get a local copy at the caller + side). Normally, depending on whether this reference is passed in a + register or reference, we either need a reference with that register + as base or load the address in that reference and use that as a new + base. + + Since the JVM cannot take the address of anything, all + "pass-by-reference" value parameters (which are always aggregate types) + are already simply the implicit pointer to the data (since arrays, + records, etc are already internally implicit pointers). This means + that if "loadref" is true, we must simply return this implicit pointer. + If it is false, we are supposed the take the address of this implicit + pointer, which is not possible. + + However, managed types are also implicit pointers in Pascal, so in that + case "taking the address" again consists of simply returning the + implicit pointer/current value (in case of a var/out parameter, this + value is stored inside an array). + } + if not loadref then + begin + if not is_managed_type(def) then + internalerror(2011020601); + tmploc:=l; + end + else + begin + if not wasmimplicitpointertype(def) then + begin + { passed by reference in array of single element; l contains the + base address of the array } + location_reset_ref(tmploc,LOC_REFERENCE,OS_ADDR,4,ref.volatility); + cgutils.reference_reset_base(tmploc.reference,getaddressregister(list,java_jlobject),0,tmploc.reference.temppos,4,ref.volatility); + tmploc.reference.arrayreftype:=art_indexconst; + tmploc.reference.indexoffset:=0; + a_load_loc_reg(list,java_jlobject,java_jlobject,l,tmploc.reference.base); + end + else + tmploc:=l; + end; + case tmploc.loc of + LOC_REGISTER, + LOC_CREGISTER : + begin + { the implicit pointer is in a register and has to be in a + reference -> create a reference and put it there } + location_force_mem(list,tmploc,java_jlobject); + ref:=tmploc.reference; + end; + LOC_REFERENCE, + LOC_CREFERENCE : + begin + ref:=tmploc.reference; + end; + else + internalerror(2011020603); + end; + end; + + procedure thlcgjvm.maybe_change_load_node_reg(list: TAsmList; var n: tnode; reload: boolean); + begin + { don't do anything, all registers become stack locations anyway } + end; + + procedure thlcgjvm.g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); + var + localref: treference; + arrloc: tlocation; + stackslots: longint; + begin + { temporary reference for passing to concatcopy } + tg.gethltemp(list,java_jlobject,java_jlobject.size,tt_persistent,localref); + stackslots:=prepare_stack_for_ref(list,localref,false); + { create the local copy of the array (lenloc is invalid, get length + directly from the array) } + location_reset_ref(arrloc,LOC_REFERENCE,OS_ADDR,sizeof(pint),ref.volatility); + arrloc.reference:=ref; + g_getarraylen(list,arrloc); + g_newarray(list,arrdef,1); + a_load_stack_ref(list,java_jlobject,localref,stackslots); + { copy the source array to the destination } + g_concatcopy(list,arrdef,ref,localref); + { and put the array pointer in the register as expected by the caller } + a_load_ref_reg(list,java_jlobject,java_jlobject,localref,destreg); + end; + + procedure thlcgjvm.g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); + begin + // do nothing, long live garbage collection! + end; + + procedure thlcgjvm.gen_initialize_code(list: TAsmList); + var + ref: treference; + begin + { create globals with wrapped types such as arrays/records } + case current_procinfo.procdef.proctypeoption of + potype_unitinit: + begin + cgutils.reference_reset_base(ref,NR_NO,0,ctempposinvalid,1,[]); + if assigned(current_module.globalsymtable) then + allocate_implicit_structs_for_st_with_base_ref(list,current_module.globalsymtable,ref,staticvarsym); + allocate_implicit_structs_for_st_with_base_ref(list,current_module.localsymtable,ref,staticvarsym); + end; + potype_class_constructor: + begin + { also initialise local variables, if any } + inherited; + { initialise class fields } + cgutils.reference_reset_base(ref,NR_NO,0,ctempposinvalid,1,[]); + allocate_implicit_structs_for_st_with_base_ref(list,tabstractrecorddef(current_procinfo.procdef.owner.defowner).symtable,ref,staticvarsym); + end + else + inherited + end; + end; + + procedure thlcgjvm.gen_entry_code(list: TAsmList); + begin + list.concat(Tai_force_line.Create); + end; + + procedure thlcgjvm.gen_exit_code(list: TAsmList); + begin + { nothing } + end; + + procedure thlcgjvm.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; srcsize, dstsize: tdef; src, dst: tregister); + begin + internalerror(2012090201); + end; + + procedure thlcgjvm.a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle); + begin + internalerror(2012090202); + end; + + procedure thlcgjvm.a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle); + begin + internalerror(2012060130); + end; + + procedure thlcgjvm.a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle); + begin + internalerror(2012060131); + end; + + procedure thlcgjvm.a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle); + begin + internalerror(2012060132); + end; + + procedure thlcgjvm.a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle); + begin + internalerror(2012060133); + end; + + procedure thlcgjvm.a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle); + begin + internalerror(2012060134); + end; + + procedure thlcgjvm.a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle); + begin + internalerror(2012060135); + end; + + procedure thlcgjvm.g_stackpointer_alloc(list: TAsmList; size: longint); + begin + internalerror(2012090203); + end; + + procedure thlcgjvm.g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint); + begin + internalerror(2012090204); + end; + + procedure thlcgjvm.g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint); + begin + internalerror(2012090205); + end; + + procedure thlcgjvm.g_local_unwind(list: TAsmList; l: TAsmLabel); + begin + internalerror(2012090206); + end; + + procedure thlcgjvm.a_load_stack_reg(list: TAsmList; size: tdef; reg: tregister); + var + opc: tasmop; + finishandval: tcgint; + begin + opc:=loadstoreopc(size,false,false,finishandval); + list.concat(taicpu.op_reg(opc,reg)); + { avoid problems with getting the size of an open array etc } + if wasmimplicitpointertype(size) then + size:=java_jlobject; + decstack(list,1+ord(size.size>4)); + end; + + procedure thlcgjvm.a_load_stack_ref(list: TAsmList; size: tdef; const ref: treference; extra_slots: longint); + var + opc: tasmop; + finishandval: tcgint; + begin + { fake location that indicates the value has to remain on the stack } + if ref.base=NR_EVAL_STACK_BASE then + exit; + opc:=loadstoreopcref(size,false,ref,finishandval); + if ref.arrayreftype=art_none then + list.concat(taicpu.op_ref(opc,ref)) + else + list.concat(taicpu.op_none(opc)); + { avoid problems with getting the size of an open array etc } + if wasmimplicitpointertype(size) then + size:=java_jlobject; + decstack(list,1+ord(size.size>4)+extra_slots); + end; + + procedure thlcgjvm.a_load_reg_stack(list: TAsmList; size: tdef; reg: tregister); + var + opc: tasmop; + finishandval: tcgint; + begin + opc:=loadstoreopc(size,true,false,finishandval); + list.concat(taicpu.op_reg(opc,reg)); + { avoid problems with getting the size of an open array etc } + if wasmimplicitpointertype(size) then + size:=java_jlobject; + incstack(list,1+ord(size.size>4)); + if finishandval<>-1 then + a_op_const_stack(list,OP_AND,size,finishandval); + end; + + procedure thlcgjvm.a_load_ref_stack(list: TAsmList; size: tdef; const ref: treference; extra_slots: longint); + var + opc: tasmop; + finishandval: tcgint; + begin + { fake location that indicates the value is already on the stack? } + if (ref.base=NR_EVAL_STACK_BASE) then + exit; + opc:=loadstoreopcref(size,true,ref,finishandval); + if ref.arrayreftype=art_none then + list.concat(taicpu.op_ref(opc,ref)) + else + list.concat(taicpu.op_none(opc)); + { avoid problems with getting the size of an open array etc } + if wasmimplicitpointertype(size) then + size:=java_jlobject; + incstack(list,1+ord(size.size>4)-extra_slots); + if finishandval<>-1 then + a_op_const_stack(list,OP_AND,size,finishandval); + if ref.checkcast then + gen_typecheck(list,a_checkcast,size); + end; + + function thlcgjvm.loadstoreopcref(def: tdef; isload: boolean; const ref: treference; out finishandval: tcgint): tasmop; + const + { isload static } + getputopc: array[boolean,boolean] of tasmop = + ((a_putfield,a_putstatic), + (a_getfield,a_getstatic)); + begin + if assigned(ref.symbol) then + begin + { -> either a global (static) field, or a regular field. If a regular + field, then ref.base contains the self pointer, otherwise + ref.base=NR_NO. In both cases, the symbol contains all other + information (combined field name and type descriptor) } + result:=getputopc[isload,ref.base=NR_NO]; + finishandval:=-1; + { erase sign extension for byte/smallint loads } + if (def2regtyp(def)=R_INTREGISTER) and + not is_signed(def) and + (def.typ=orddef) and + not is_widechar(def) then + case def.size of + 1: if (torddef(def).high>127) then + finishandval:=255; + 2: if (torddef(def).high>32767) then + finishandval:=65535; + end; + end + else + result:=loadstoreopc(def,isload,ref.arrayreftype<>art_none,finishandval); + end; + + function thlcgjvm.loadstoreopc(def: tdef; isload, isarray: boolean; out finishandval: tcgint): tasmop; + var + size: longint; + begin + finishandval:=-1; + case def2regtyp(def) of + R_INTREGISTER: + begin + size:=def.size; + if not isarray then + begin + case size of + 1,2,3,4: + if isload then + result:=a_iload + else + result:=a_istore; + 8: + if isload then + result:=a_lload + else + result:=a_lstore; + else + internalerror(2011032814); + end; + end + { array } + else if isload then + begin + case size of + 1: + begin + result:=a_baload; + if not is_signed(def) and + (def.typ=orddef) and + (torddef(def).high>127) then + finishandval:=255; + end; + 2: + begin + if is_widechar(def) then + result:=a_caload + else + begin + result:=a_saload; + { if we'd treat arrays of word as "array of widechar" we + could use a_caload, but that would make for even more + awkward interfacing with external Java code } + if not is_signed(def) and + (def.typ=orddef) and + (torddef(def).high>32767) then + finishandval:=65535; + end; + end; + 4: result:=a_iaload; + 8: result:=a_laload; + else + internalerror(2010120503); + end + end + else + begin + case size of + 1: result:=a_bastore; + 2: if not is_widechar(def) then + result:=a_sastore + else + result:=a_castore; + 4: result:=a_iastore; + 8: result:=a_lastore; + else + internalerror(2010120508); + end + end + end; + R_ADDRESSREGISTER: + if not isarray then + if isload then + result:=a_aload + else + result:=a_astore + else if isload then + result:=a_aaload + else + result:=a_aastore; + R_FPUREGISTER: + begin + case tfloatdef(def).floattype of + s32real: + if not isarray then + if isload then + result:=a_fload + else + result:=a_fstore + else if isload then + result:=a_faload + else + result:=a_fastore; + s64real: + if not isarray then + if isload then + result:=a_dload + else + result:=a_dstore + else if isload then + result:=a_daload + else + result:=a_dastore; + else + internalerror(2010120504); + end + end + else + internalerror(2010120502); + end; + end; + + procedure thlcgjvm.resize_stack_int_val(list: TAsmList; fromsize, tosize: tdef; formemstore: boolean); + var + fromcgsize, tocgsize: tcgsize; + begin + { When storing to an array, field or global variable, make sure the + static type verification can determine that the stored value fits + within the boundaries of the declared type (to appease the Dalvik VM). + Local variables either get their type upgraded in the debug info, + or have no type information at all } + if formemstore and + (tosize.typ=orddef) then + if (torddef(tosize).ordtype in [u8bit,uchar]) then + tosize:=s8inttype + else if torddef(tosize).ordtype=u16bit then + tosize:=s16inttype; + + fromcgsize:=def_cgsize(fromsize); + tocgsize:=def_cgsize(tosize); + if fromcgsize in [OS_S64,OS_64] then + begin + if not(tocgsize in [OS_S64,OS_64]) then + begin + { truncate } + list.concat(taicpu.op_none(a_l2i)); + decstack(list,1); + end; + end + else if tocgsize in [OS_S64,OS_64] then + begin + { extend } + list.concat(taicpu.op_none(a_i2l)); + incstack(list,1); + { if it was an unsigned 32 bit value, remove sign extension } + if fromcgsize=OS_32 then + a_op_const_stack(list,OP_AND,s64inttype,cardinal($ffffffff)); + end; + { Conversions between 32 and 64 bit types have been completely handled + above. We still may have to truncate or sign extend in case the + destination type is smaller that the source type, or has a different + sign. In case the destination is a widechar and the source is not, we + also have to insert a conversion to widechar. + + In case of Dalvik, we also have to insert conversions for e.g. byte + -> smallint, because truncating a byte happens via "and 255", and the + result is a longint in Dalvik's type verification model (so we have + to "truncate" it back to smallint) } + if (not(fromcgsize in [OS_S64,OS_64,OS_32,OS_S32]) or + not(tocgsize in [OS_S64,OS_64,OS_32,OS_S32])) and + (((current_settings.cputype=cpu_dalvik) and + not(tocgsize in [OS_32,OS_S32]) and + not is_signed(fromsize) and + is_signed(tosize)) or + (tcgsize2size[fromcgsize]>tcgsize2size[tocgsize]) or + ((tcgsize2size[fromcgsize]=tcgsize2size[tocgsize]) and + (fromcgsize<>tocgsize)) or + { needs to mask out the sign in the top 16 bits } + ((fromcgsize=OS_S8) and + (tocgsize=OS_16)) or + ((tosize=cwidechartype) and + (fromsize<>cwidechartype))) then + case tocgsize of + OS_8: + a_op_const_stack(list,OP_AND,s32inttype,255); + OS_S8: + list.concat(taicpu.op_none(a_i2b)); + OS_16: + if (tosize.typ=orddef) and + (torddef(tosize).ordtype=uwidechar) then + list.concat(taicpu.op_none(a_i2c)) + else + a_op_const_stack(list,OP_AND,s32inttype,65535); + OS_S16: + list.concat(taicpu.op_none(a_i2s)); + else + ; + end; + end; + + procedure thlcgjvm.maybe_resize_stack_para_val(list: TAsmList; retdef: tdef; callside: boolean); + var + convsize: tdef; + begin + if (retdef.typ=orddef) then + begin + if (torddef(retdef).ordtype in [u8bit,u16bit,uchar]) and + (torddef(retdef).high>=(1 shl (retdef.size*8-1))) then + begin + convsize:=nil; + if callside then + if torddef(retdef).ordtype in [u8bit,uchar] then + convsize:=s8inttype + else + convsize:=s16inttype + else if torddef(retdef).ordtype in [u8bit,uchar] then + convsize:=u8inttype + else + convsize:=u16inttype; + if assigned(convsize) then + resize_stack_int_val(list,s32inttype,convsize,false); + end; + end; + end; + + + procedure thlcgjvm.g_adjust_stack_after_call(list: TAsmList; pd: tabstractprocdef; paraheight: longint; forceresdef: tdef); + var + totalremovesize: longint; + realresdef: tdef; + begin + if not assigned(forceresdef) then + realresdef:=pd.returndef + else + realresdef:=forceresdef; + { a constructor doesn't actually return a value in the jvm } + if (tabstractprocdef(pd).proctypeoption=potype_constructor) then + totalremovesize:=paraheight + else + { even a byte takes up a full stackslot -> align size to multiple of 4 } + totalremovesize:=paraheight-(align(realresdef.size,4) shr 2); + { remove parameters from internal evaluation stack counter (in case of + e.g. no parameters and a result, it can also increase) } + if totalremovesize>0 then + decstack(list,totalremovesize) + else if totalremovesize<0 then + incstack(list,-totalremovesize); + end; + + + procedure thlcgjvm.allocate_implicit_struct_with_base_ref(list: TAsmList; vs: tabstractvarsym; ref: treference); + var + tmpref: treference; + begin + ref.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname,AT_DATA); + tg.gethltemp(list,vs.vardef,vs.vardef.size,tt_persistent,tmpref); + { only copy the reference, not the actual data } + a_load_ref_ref(list,java_jlobject,java_jlobject,tmpref,ref); + { remains live since there's still a reference to the created + entity } + tg.ungettemp(list,tmpref); + end; + + + procedure thlcgjvm.allocate_enum_with_base_ref(list: TAsmList; vs: tabstractvarsym; const initref: treference; destbaseref: treference); + begin + destbaseref.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname,AT_DATA); + { only copy the reference, not the actual data } + a_load_ref_ref(list,java_jlobject,java_jlobject,initref,destbaseref); + end; + + + function thlcgjvm.get_enum_init_val_ref(def: tdef; out ref: treference): boolean; + var + sym: tstaticvarsym; + begin + result:=false; + sym:=tstaticvarsym(tcpuenumdef(tenumdef(def).getbasedef).classdef.symtable.Find('__FPC_ZERO_INITIALIZER')); + { no enum with ordinal value 0 -> exit } + if not assigned(sym) then + exit; + reference_reset_symbol(ref,current_asmdata.RefAsmSymbol(sym.mangledname,AT_DATA),0,4,[]); + result:=true; + end; + + + procedure thlcgjvm.allocate_implicit_structs_for_st_with_base_ref(list: TAsmList; st: tsymtable; const ref: treference; allocvartyp: tsymtyp); + var + vs: tabstractvarsym; + def: tdef; + i: longint; + initref: treference; + begin + for i:=0 to st.symlist.count-1 do + begin + if (tsym(st.symlist[i]).typ<>allocvartyp) then + continue; + vs:=tabstractvarsym(st.symlist[i]); + if sp_static in vs.symoptions then + continue; + { vo_is_external and vo_has_local_copy means a staticvarsym that is + alias for a constsym, whose sole purpose is for allocating and + intialising the constant } + if [vo_is_external,vo_has_local_copy]*vs.varoptions=[vo_is_external] then + continue; + { threadvar innitializations are handled at the node tree level } + if vo_is_thread_var in vs.varoptions then + begin + { nothing } + end + else if wasmimplicitpointertype(vs.vardef) then + allocate_implicit_struct_with_base_ref(list,vs,ref) + { enums are class instances in Java, while they are ordinals in + Pascal. When they are initialized with enum(0), such as in + constructors or global variables, initialize them with the + enum instance for 0 if it exists (if not, it remains nil since + there is no valid enum value in it) } + else if (vs.vardef.typ=enumdef) and + ((vs.typ<>fieldvarsym) or + (tdef(vs.owner.defowner).typ<>objectdef) or + (ts_jvm_enum_field_init in current_settings.targetswitches)) and + get_enum_init_val_ref(vs.vardef,initref) then + allocate_enum_with_base_ref(list,vs,initref,ref); + end; + { process symtables of routines part of this symtable (for local typed + constants) } + if allocvartyp=staticvarsym then + begin + for i:=0 to st.deflist.count-1 do + begin + def:=tdef(st.deflist[i]); + { the unit symtable also contains the methods of classes defined + in that unit -> skip them when processing the unit itself. + Localst is not assigned for the main program code. + Localst can be the same as st in case of unit init code. } + if (def.typ<>procdef) or + (def.owner<>st) or + not assigned(tprocdef(def).localst) or + (tprocdef(def).localst=st) then + continue; + allocate_implicit_structs_for_st_with_base_ref(list,tprocdef(def).localst,ref,allocvartyp); + end; + end; + end; + + procedure thlcgjvm.gen_initialize_fields_code(list: TAsmList); + var + sym: tsym; + selfpara: tparavarsym; + selfreg: tregister; + ref: treference; + obj: tabstractrecorddef; + i: longint; + needinit: boolean; + begin + obj:=tabstractrecorddef(current_procinfo.procdef.owner.defowner); + { check whether there are any fields that need initialisation } + needinit:=false; + for i:=0 to obj.symtable.symlist.count-1 do + begin + sym:=tsym(obj.symtable.symlist[i]); + if (sym.typ=fieldvarsym) and + not(sp_static in sym.symoptions) and + (wasmimplicitpointertype(tfieldvarsym(sym).vardef) or + ((tfieldvarsym(sym).vardef.typ=enumdef) and + get_enum_init_val_ref(tfieldvarsym(sym).vardef,ref))) then + begin + needinit:=true; + break; + end; + end; + if not needinit then + exit; + selfpara:=tparavarsym(current_procinfo.procdef.parast.find('self')); + if not assigned(selfpara) then + internalerror(2011033001); + selfreg:=getaddressregister(list,selfpara.vardef); + a_load_loc_reg(list,obj,obj,selfpara.localloc,selfreg); + cgutils.reference_reset_base(ref,selfreg,0,ctempposinvalid,1,[]); + allocate_implicit_structs_for_st_with_base_ref(list,obj.symtable,ref,fieldvarsym); + end; + + procedure thlcgjvm.gen_typecheck(list: TAsmList; checkop: tasmop; checkdef: tdef); + begin + { replace special types with their equivalent class type } + if (checkdef.typ=pointerdef) and + wasmimplicitpointertype(tpointerdef(checkdef).pointeddef) then + checkdef:=tpointerdef(checkdef).pointeddef; + if (checkdef=voidpointertype) or + (checkdef.typ=formaldef) then + checkdef:=java_jlobject + else if checkdef.typ=enumdef then + checkdef:=tcpuenumdef(checkdef).classdef + else if checkdef.typ=setdef then + begin + if tsetdef(checkdef).elementdef.typ=enumdef then + checkdef:=java_juenumset + else + checkdef:=java_jubitset; + end + else if checkdef.typ=procvardef then + checkdef:=tcpuprocvardef(checkdef).classdef + else if is_wide_or_unicode_string(checkdef) then + checkdef:=java_jlstring + else if is_ansistring(checkdef) then + checkdef:=java_ansistring + else if is_shortstring(checkdef) then + checkdef:=java_shortstring; + if checkdef.typ in [objectdef,recorddef] then + list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol(tabstractrecorddef(checkdef).jvm_full_typename(true),AT_METADATA))) + else if checkdef.typ=classrefdef then + list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol('java/lang/Class',AT_METADATA))) + { todo: WASM + else + list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol(jvmencodetype(checkdef,false),AT_METADATA))); + } + end; + + procedure thlcgjvm.resizestackfpuval(list: TAsmList; fromsize, tosize: tcgsize); + begin + if (fromsize=OS_F32) and + (tosize=OS_F64) then + begin + list.concat(taicpu.op_none(a_f2d)); + incstack(list,1); + end + else if (fromsize=OS_F64) and + (tosize=OS_F32) then + begin + list.concat(taicpu.op_none(a_d2f)); + decstack(list,1); + end; + end; + + procedure thlcgjvm.maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean); + begin + if (op=OP_DIV) and + (def_cgsize(size)=OS_32) then + begin + { needs zero-extension to 64 bit, because the JVM only supports + signed divisions } + resize_stack_int_val(list,u32inttype,s64inttype,false); + op:=OP_IDIV; + isdivu32:=true; + end + else + isdivu32:=false; + end; + + function thlcgjvm.a_call_name_intern(list: TAsmList; pd: tprocdef; const s: TSymStr; forceresdef: tdef; inheritedcall: boolean): tcgpara; + var + opc: tasmop; + begin + { + invoke types: + * invokeinterface: call method from an interface (must also specify + number of parameters in terms of stack slot count!) + * invokespecial: invoke a constructor, method in a superclass, + or private instance method + * invokestatic: invoke a class method (private or not) + * invokevirtual: invoke a regular method + } + case pd.owner.symtabletype of + globalsymtable, + staticsymtable, + localsymtable: + { regular and nested procedures are turned into static methods } + opc:=a_invokestatic; + objectsymtable: + begin + case tobjectdef(pd.owner.defowner).objecttype of + odt_javaclass: + begin + if (po_classmethod in pd.procoptions) or + (pd.proctypeoption=potype_operator) then + opc:=a_invokestatic + else if (pd.visibility=vis_strictprivate) or + (pd.proctypeoption=potype_constructor) or + inheritedcall then + opc:=a_invokespecial + else + opc:=a_invokevirtual; + end; + odt_interfacejava: + { static interface methods are not allowed } + opc:=a_invokeinterface; + else + internalerror(2010122601); + end; + end; + recordsymtable: + begin + if (po_staticmethod in pd.procoptions) or + (pd.proctypeoption=potype_operator) then + opc:=a_invokestatic + else if (pd.visibility=vis_strictprivate) or + (pd.proctypeoption=potype_constructor) or + inheritedcall then + opc:=a_invokespecial + else + opc:=a_invokevirtual; + end + else + internalerror(2010122602); + end; + if (opc<>a_invokeinterface) then + list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(s,AT_FUNCTION))) + else + begin + pd.init_paraloc_info(calleeside); + list.concat(taicpu.op_sym_const(opc,current_asmdata.RefAsmSymbol(s,AT_FUNCTION),pd.calleeargareasize)); + end; + result:=get_call_result_cgpara(pd,forceresdef); + end; + + procedure create_hlcodegen_cpu; + begin + hlcg:=thlcgjvm.create; + create_codegen; + end; + +begin + chlcgobj:=thlcgjvm; + create_hlcodegen:=@create_hlcodegen_cpu; +end. diff --git a/compiler/wasm/rgcpu.pas b/compiler/wasm/rgcpu.pas new file mode 100644 index 0000000000..fcbfdb6c95 --- /dev/null +++ b/compiler/wasm/rgcpu.pas @@ -0,0 +1,417 @@ +{ + Copyright (c) 2010 by Jonas Maebe + + This unit implements the WebAssembly specific class for the register + allocator + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + ****************************************************************************} +unit rgcpu; + +{$i fpcdefs.inc} + + interface + + uses + aasmbase,aasmcpu,aasmtai,aasmdata, + cgbase,cgutils, + cpubase, + rgobj; + + type + tspilltemps = array[tregistertype] of ^Tspill_temp_list; + + { trgcpu } + + trgcpu=class(trgobj) + protected + class procedure do_spill_replace_all(list:TAsmList;instr:taicpu;const spilltemps: tspilltemps); + class procedure remove_dummy_load_stores(list: TAsmList; headertai: tai); + public + { performs the register allocation for *all* register types } + class procedure do_all_register_allocation(list: TAsmList; headertai: tai); + end; + + +implementation + + uses + verbose,cutils, + globtype,globals, + cgobj, + tgobj; + + { trgcpu } + + class procedure trgcpu.do_spill_replace_all(list:TAsmList;instr:taicpu;const spilltemps: tspilltemps); + var + l: longint; + reg: tregister; + begin + { jvm instructions never have more than one memory (virtual register) + operand, so there is no danger of superregister conflicts } + for l:=0 to instr.ops-1 do + if instr.oper[l]^.typ=top_reg then + begin + reg:=instr.oper[l]^.reg; + instr.loadref(l,spilltemps[getregtype(reg)]^[getsupreg(reg)]); + end; + end; + + + class procedure trgcpu.remove_dummy_load_stores(list: TAsmList; headertai: tai); + + type + taitypeset = set of taitype; + + function nextskipping(p: tai; const skip: taitypeset): tai; + begin + result:=p; + if not assigned(result) then + exit; + repeat + result:=tai(result.next); + until not assigned(result) or + not(result.typ in skip); + end; + + function issimpleregstore(p: tai; var reg: tregister; doubleprecisionok: boolean): boolean; + const + simplestoressp = [a_astore,a_fstore,a_istore]; + simplestoresdp = [a_dstore,a_lstore]; + begin + result:= + assigned(p) and + (p.typ=ait_instruction) and + ((taicpu(p).opcode in simplestoressp) or + (doubleprecisionok and + (taicpu(p).opcode in simplestoresdp))) and + ((reg=NR_NO) or + (taicpu(p).oper[0]^.typ=top_reg) and + (taicpu(p).oper[0]^.reg=reg)); + if result and + (reg=NR_NO) then + reg:=taicpu(p).oper[0]^.reg; + end; + + function issimpleregload(p: tai; var reg: tregister; doubleprecisionok: boolean): boolean; + const + simpleloadssp = [a_aload,a_fload,a_iload]; + simpleloadsdp = [a_dload,a_lload]; + begin + result:= + assigned(p) and + (p.typ=ait_instruction) and + ((taicpu(p).opcode in simpleloadssp) or + (doubleprecisionok and + (taicpu(p).opcode in simpleloadsdp))) and + ((reg=NR_NO) or + (taicpu(p).oper[0]^.typ=top_reg) and + (taicpu(p).oper[0]^.reg=reg)); + if result and + (reg=NR_NO) then + reg:=taicpu(p).oper[0]^.reg; + end; + + function isregallocoftyp(p: tai; typ: TRegAllocType;var reg: tregister): boolean; + begin + result:= + assigned(p) and + (p.typ=ait_regalloc) and + (tai_regalloc(p).ratype=typ); + if result then + if reg=NR_NO then + reg:=tai_regalloc(p).reg + else + result:=tai_regalloc(p).reg=reg; + end; + + function regininstruction(p: tai; reg: tregister): boolean; + var + sr: tsuperregister; + i: longint; + begin + result:=false; + if p.typ<>ait_instruction then + exit; + sr:=getsupreg(reg); + for i:=0 to taicpu(p).ops-1 do + case taicpu(p).oper[0]^.typ of + top_reg: + if (getsupreg(taicpu(p).oper[0]^.reg)=sr) then + exit(true); + top_ref: + begin + if (getsupreg(taicpu(p).oper[0]^.ref^.base)=sr) then + exit(true); + if (getsupreg(taicpu(p).oper[0]^.ref^.index)=sr) then + exit(true); + if (getsupreg(taicpu(p).oper[0]^.ref^.indexbase)=sr) then + exit(true); + if (getsupreg(taicpu(p).oper[0]^.ref^.indexbase)=sr) then + exit(true); + end; + else + ; + end; + end; + + function try_remove_store_dealloc_load(var p: tai): boolean; + var + dealloc, + load: tai; + reg: tregister; + begin + result:=false; + { check for: + store regx + dealloc regx + load regx + and remove. We don't have to check that the load/store + types match, because they have to for this to be + valid JVM code } + dealloc:=nextskipping(p,[ait_comment,ait_tempalloc]); + load:=nextskipping(dealloc,[ait_comment,ait_tempalloc]); + reg:=NR_NO; + if issimpleregstore(p,reg,true) and + isregallocoftyp(dealloc,ra_dealloc,reg) and + issimpleregload(load,reg,true) then + begin + { remove the whole sequence: the store } + list.remove(p); + p.free; + p:=Tai(load.next); + { the load } + list.remove(load); + load.free; + + result:=true; + end; + end; + + + function try_swap_store_x_load(var p: tai): boolean; + var + insertpos, + storex, + deallocy, + loady, + deallocx, + loadx: tai; + swapxy: taicpu; + regx, regy: tregister; + begin + result:=false; + { check for: + alloc regx (optional) + store regx (p) + dealloc regy + load regy + dealloc regx + load regx + and change to + dealloc regy + load regy + swap + alloc regx (if it existed) + store regx + dealloc regx + load regx + + This will create opportunities to remove the store/load regx + (and possibly also for regy) + } + regx:=NR_NO; + regy:=NR_NO; + if not issimpleregstore(p,regx,false) then + exit; + storex:=p; + deallocy:=nextskipping(storex,[ait_comment,ait_tempalloc]); + loady:=nextskipping(deallocy,[ait_comment,ait_tempalloc]); + deallocx:=nextskipping(loady,[ait_comment,ait_tempalloc]); + loadx:=nextskipping(deallocx,[ait_comment,ait_tempalloc]); + if not assigned(loadx) then + exit; + if not issimpleregload(loady,regy,false) then + exit; + if not issimpleregload(loadx,regx,false) then + exit; + if not isregallocoftyp(deallocy,ra_dealloc,regy) then + exit; + if not isregallocoftyp(deallocx,ra_dealloc,regx) then + exit; + insertpos:=tai(p.previous); + if not assigned(insertpos) or + not isregallocoftyp(insertpos,ra_alloc,regx) then + insertpos:=storex; + list.remove(deallocy); + list.insertbefore(deallocy,insertpos); + list.remove(loady); + list.insertbefore(loady,insertpos); + swapxy:=taicpu.op_none(a_swap); + swapxy.fileinfo:=taicpu(loady).fileinfo; + list.insertbefore(swapxy,insertpos); + result:=true; + end; + + + var + p,next,nextnext: tai; + reg: tregister; + removedsomething: boolean; + begin + repeat + removedsomething:=false; + p:=headertai; + while assigned(p) do + begin + case p.typ of + ait_regalloc: + begin + reg:=NR_NO; + next:=nextskipping(p,[ait_comment,ait_tempalloc]); + nextnext:=nextskipping(next,[ait_comment,ait_regalloc]); + if assigned(nextnext) then + begin + { remove + alloc reg + dealloc reg + + (can appear after optimisations, necessary to prevent + useless stack slot allocations) } + if isregallocoftyp(p,ra_alloc,reg) and + isregallocoftyp(next,ra_dealloc,reg) and + not regininstruction(nextnext,reg) then + begin + list.remove(p); + p.free; + p:=tai(next.next); + list.remove(next); + next.free; + removedsomething:=true; + continue; + end; + end; + end; + ait_instruction: + begin + if try_remove_store_dealloc_load(p) or + try_swap_store_x_load(p) then + begin + removedsomething:=true; + continue; + end; + end; + else + ; + end; + p:=tai(p.next); + end; + until not removedsomething; + end; + + + class procedure trgcpu.do_all_register_allocation(list: TAsmList; headertai: tai); + var + spill_temps : tspilltemps; + templist : TAsmList; + intrg, + fprg : trgcpu; + p,q : tai; + size : longint; + begin + { Since there are no actual registers, we simply spill everything. We + use tt_regallocator temps, which are not used by the temp allocator + during code generation, so that we cannot accidentally overwrite + any temporary values } + + { get references to all register allocators } + intrg:=trgcpu(cg.rg[R_INTREGISTER]); + fprg:=trgcpu(cg.rg[R_FPUREGISTER]); + { determine the live ranges of all registers } + intrg.insert_regalloc_info_all(list); + fprg.insert_regalloc_info_all(list); + { Don't do the actual allocation when -sr is passed } + if (cs_no_regalloc in current_settings.globalswitches) then + exit; + { remove some simple useless store/load sequences } + remove_dummy_load_stores(list,headertai); + { allocate room to store the virtual register -> temp mapping } + spill_temps[R_INTREGISTER]:=allocmem(sizeof(treference)*intrg.maxreg); + spill_temps[R_FPUREGISTER]:=allocmem(sizeof(treference)*fprg.maxreg); + { List to insert temp allocations into } + templist:=TAsmList.create; + { allocate/replace all registers } + p:=headertai; + while assigned(p) do + begin + case p.typ of + ait_regalloc: + with Tai_regalloc(p) do + begin + case getregtype(reg) of + R_INTREGISTER: + if getsubreg(reg)=R_SUBD then + size:=4 + else + size:=8; + R_ADDRESSREGISTER: + size:=4; + R_FPUREGISTER: + if getsubreg(reg)=R_SUBFS then + size:=4 + else + size:=8; + else + internalerror(2010122912); + end; + case ratype of + ra_alloc : + tg.gettemp(templist, + size,1, + tt_regallocator,spill_temps[getregtype(reg)]^[getsupreg(reg)]); + ra_dealloc : + begin + tg.ungettemp(templist,spill_temps[getregtype(reg)]^[getsupreg(reg)]); + { don't invalidate the temp reference, may still be used one instruction + later } + end; + else + ; + end; + { insert the tempallocation/free at the right place } + list.insertlistbefore(p,templist); + { remove the register allocation info for the register + (p.previous is valid because we just inserted the temp + allocation/free before p) } + q:=Tai(p.previous); + list.remove(p); + p.free; + p:=q; + end; + ait_instruction: + do_spill_replace_all(list,taicpu(p),spill_temps); + else + ; + end; + p:=Tai(p.next); + end; + freemem(spill_temps[R_INTREGISTER]); + freemem(spill_temps[R_FPUREGISTER]); + templist.free; + end; + +end. diff --git a/compiler/wasm/rwasmcon.inc b/compiler/wasm/rwasmcon.inc new file mode 100644 index 0000000000..bcb17b1f8f --- /dev/null +++ b/compiler/wasm/rwasmcon.inc @@ -0,0 +1,5 @@ +{ don't edit, this file is generated from wasmreg.dat } +NR_NO = tregister($00000000); +NR_R0 = tregister($01000000); +NR_R1 = tregister($01000001); +NR_R2 = tregister($01000002); diff --git a/compiler/wasm/rwasmnor.inc b/compiler/wasm/rwasmnor.inc new file mode 100644 index 0000000000..0c6dad0c22 --- /dev/null +++ b/compiler/wasm/rwasmnor.inc @@ -0,0 +1,2 @@ +{ don't edit, this file is generated from wasmreg.dat } +4 diff --git a/compiler/wasm/rwasmnum.inc b/compiler/wasm/rwasmnum.inc new file mode 100644 index 0000000000..a2b5587aee --- /dev/null +++ b/compiler/wasm/rwasmnum.inc @@ -0,0 +1,5 @@ +{ don't edit, this file is generated from wasmreg.dat } +tregister($00000000), +tregister($01000000), +tregister($01000001), +tregister($01000002) diff --git a/compiler/wasm/rwasmrni.inc b/compiler/wasm/rwasmrni.inc new file mode 100644 index 0000000000..d22f653434 --- /dev/null +++ b/compiler/wasm/rwasmrni.inc @@ -0,0 +1,5 @@ +{ don't edit, this file is generated from wasmreg.dat } +0, +1, +2, +3 diff --git a/compiler/wasm/rwasmsri.inc b/compiler/wasm/rwasmsri.inc new file mode 100644 index 0000000000..3ec6e965f6 --- /dev/null +++ b/compiler/wasm/rwasmsri.inc @@ -0,0 +1,5 @@ +{ don't edit, this file is generated from wasmreg.dat } +0, +3, +1, +2 diff --git a/compiler/wasm/rwasmstd.inc b/compiler/wasm/rwasmstd.inc new file mode 100644 index 0000000000..ef1711ff1e --- /dev/null +++ b/compiler/wasm/rwasmstd.inc @@ -0,0 +1,5 @@ +{ don't edit, this file is generated from wasmreg.dat } +'INVALID', +'evalstacktopptr', +'localsstackptr', +'evalstacktop' diff --git a/compiler/wasm/rwasmsup.inc b/compiler/wasm/rwasmsup.inc new file mode 100644 index 0000000000..64e71c684d --- /dev/null +++ b/compiler/wasm/rwasmsup.inc @@ -0,0 +1,5 @@ +{ don't edit, this file is generated from wasmreg.dat } +RS_NO = $00; +RS_R0 = $00; +RS_R1 = $01; +RS_R2 = $02; diff --git a/compiler/wasm/symcpu.pas b/compiler/wasm/symcpu.pas new file mode 100644 index 0000000000..8618b1a40f --- /dev/null +++ b/compiler/wasm/symcpu.pas @@ -0,0 +1,954 @@ +{ + Copyright (c) 2014 by Florian Klaempfl + + Symbol table overrides for WebAssembly + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit symcpu; + +{$i fpcdefs.inc} + +interface + +uses + globtype, + aasmdata, + symtype, + symdef,symsym; + +type + { defs } + tcpufiledef = class(tfiledef) + end; + tcpufiledefclass = class of tcpufiledef; + + tcpuvariantdef = class(tvariantdef) + end; + tcpuvariantdefclass = class of tcpuvariantdef; + + tcpuformaldef = class(tformaldef) + end; + tcpuformaldefclass = class of tcpuformaldef; + + tcpuforwarddef = class(tforwarddef) + end; + tcpuforwarddefclass = class of tcpuforwarddef; + + tcpuundefineddef = class(tundefineddef) + end; + tcpuundefineddefclass = class of tcpuundefineddef; + + tcpuerrordef = class(terrordef) + end; + tcpuerrordefclass = class of tcpuerrordef; + + tcpupointerdef = class(tpointerdef) + end; + tcpupointerdefclass = class of tcpupointerdef; + + tcpurecorddef = class(trecorddef) + end; + tcpurecorddefclass = class of tcpurecorddef; + + tcpuimplementedinterface = class(timplementedinterface) + end; + tcpuimplementedinterfaceclass = class of tcpuimplementedinterface; + + tcpuobjectdef = class(tobjectdef) + end; + tcpuobjectdefclass = class of tcpuobjectdef; + + tcpuclassrefdef = class(tclassrefdef) + end; + tcpuclassrefdefclass = class of tcpuclassrefdef; + + tcpuarraydef = class(tarraydef) + end; + tcpuarraydefclass = class of tcpuarraydef; + + tcpuorddef = class(torddef) + end; + tcpuorddefclass = class of tcpuorddef; + + tcpufloatdef = class(tfloatdef) + end; + tcpufloatdefclass = class of tcpufloatdef; + + tcpuprocvardef = class(tprocvardef) + protected + procedure ppuwrite_platform(ppufile: tcompilerppufile); override; + procedure ppuload_platform(ppufile: tcompilerppufile); override; + public + { class representing this procvar on the Java side } + classdef : tobjectdef; + classdefderef : tderef; + procedure buildderef;override; + procedure deref;override; + function getcopy: tstoreddef; override; + end; + tcpuprocvardefclass = class of tcpuprocvardef; + + tcpuprocdef = class(tprocdef) + { generated assembler code; used by JVM backend so it can afterwards + easily write out all methods grouped per class } + exprasmlist : TAsmList; + function jvmmangledbasename(signature: boolean): TSymStr; + function mangledname: TSymStr; override; + function getfuncretsyminfo(out ressym: tsym; out resdef: tdef): boolean; override; + destructor destroy; override; + end; + tcpuprocdefclass = class of tcpuprocdef; + + tcpustringdef = class(tstringdef) + end; + tcpustringdefclass = class of tcpustringdef; + + tcpuenumdef = class(tenumdef) + protected + procedure ppuload_platform(ppufile: tcompilerppufile); override; + procedure ppuwrite_platform(ppufile: tcompilerppufile); override; + public + { class representing this enum on the Java side } + classdef : tobjectdef; + classdefderef : tderef; + function getcopy: tstoreddef; override; + procedure buildderef; override; + procedure deref; override; + end; + tcpuenumdefclass = class of tcpuenumdef; + + tcpusetdef = class(tsetdef) + end; + tcpusetdefclass = class of tcpusetdef; + + { syms } + tcpulabelsym = class(tlabelsym) + end; + tcpulabelsymclass = class of tcpulabelsym; + + tcpuunitsym = class(tunitsym) + end; + tcpuunitsymclass = class of tcpuunitsym; + + tcpuprogramparasym = class(tprogramparasym) + end; + tcpuprogramparasymclass = class(tprogramparasym); + + tcpunamespacesym = class(tnamespacesym) + end; + tcpunamespacesymclass = class of tcpunamespacesym; + + tcpuprocsym = class(tprocsym) + procedure check_forward; override; + end; + tcpuprocsymclass = class of tcpuprocsym; + + tcputypesym = class(ttypesym) + end; + tcpuypesymclass = class of tcputypesym; + + tcpufieldvarsym = class(tfieldvarsym) + procedure set_externalname(const s: string); override; + function mangledname: TSymStr; override; + end; + tcpufieldvarsymclass = class of tcpufieldvarsym; + + tcpulocalvarsym = class(tlocalvarsym) + end; + tcpulocalvarsymclass = class of tcpulocalvarsym; + + tcpuparavarsym = class(tparavarsym) + end; + tcpuparavarsymclass = class of tcpuparavarsym; + + tcpustaticvarsym = class(tstaticvarsym) + procedure set_mangledname(const s: TSymStr); override; + function mangledname: TSymStr; override; + end; + tcpustaticvarsymclass = class of tcpustaticvarsym; + + tcpuabsolutevarsym = class(tabsolutevarsym) + end; + tcpuabsolutevarsymclass = class of tcpuabsolutevarsym; + + tcpupropertysym = class(tpropertysym) + protected + { when a private/protected field is exposed via a property with a higher + visibility, then we have to create a getter and/or setter with that same + higher visibility to make sure that using the property does not result + in JVM verification errors } + procedure create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean); + procedure finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef); override; + procedure maybe_create_overridden_getter_or_setter(getset: tpropaccesslisttypes); + public + procedure inherit_accessor(getset: tpropaccesslisttypes); override; + end; + tcpupropertysymclass = class of tcpupropertysym; + + tcpuconstsym = class(tconstsym) + end; + tcpuconstsymclass = class of tcpuconstsym; + + tcpuenumsym = class(tenumsym) + end; + tcpuenumsymclass = class of tcpuenumsym; + + tcpusyssym = class(tsyssym) + end; + tcpusyssymclass = class of tcpusyssym; + + +const + pbestrealtype : ^tdef = @s64floattype; + + +implementation + + uses + verbose,cutils,cclasses,globals, + symconst,symbase,symtable,symcreat,wasmdef, + pdecsub,pparautl,{pjvm,} + paramgr; + + + {**************************************************************************** + tcpuproptertysym + ****************************************************************************} + + procedure tcpupropertysym.create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean); + var + obj: tabstractrecorddef; + ps: tprocsym; + pvs: tparavarsym; + sym: tsym; + pd, parentpd, accessorparapd: tprocdef; + tmpaccesslist: tpropaccesslist; + callthroughpropname, + accessorname: string; + callthroughprop: tpropertysym; + accesstyp: tpropaccesslisttypes; + accessortyp: tprocoption; + procoptions: tprocoptions; + paranr: word; + explicitwrapper: boolean; + begin + obj:=current_structdef; + { if someone gets the idea to add a property to an external class + definition, don't try to wrap it since we cannot add methods to + external classes } + if oo_is_external in obj.objectoptions then + exit; + symtablestack.push(obj.symtable); + + try + if getter then + accesstyp:=palt_read + else + accesstyp:=palt_write; + + { we can't use str_parse_method_dec here because the type of the field + may not be visible at the Pascal level } + + explicitwrapper:= + { private methods are not visibile outside the current class, so + no use in making life harder for us by introducing potential + (future or current) naming conflicts } + (visibility<>vis_private) and + (getter and + (prop_auto_getter_prefix<>'')) or + (not getter and + (prop_auto_setter_prefix<>'')); + sym:=nil; + if getter then + accessortyp:=po_is_auto_getter + else + accessortyp:=po_is_auto_setter; + procoptions:=[accessortyp]; + if explicitwrapper then + begin + if getter then + accessorname:=prop_auto_getter_prefix+realname + else + accessorname:=prop_auto_setter_prefix+realname; + sym:=search_struct_member_no_helper(obj,upper(accessorname)); + if assigned(sym) then + begin + if ((sym.typ<>procsym) or + (tprocsym(sym).procdeflist.count<>1) or + not(accessortyp in tprocdef(tprocsym(sym).procdeflist[0]).procoptions)) and + (not assigned(orgaccesspd) or + (sym<>orgaccesspd.procsym)) then + begin + MessagePos2(fileinfo,parser_e_cannot_generate_property_getter_setter,accessorname,FullTypeName(tdef(sym.owner.defowner),nil)+'.'+accessorname); + exit; + end + else + begin + if accessorname<>sym.realname then + MessagePos2(fileinfo,parser_w_case_difference_auto_property_getter_setter_prefix,sym.realname,accessorname); + { is the specified getter/setter defined in the current + struct and was it originally specified as the getter/ + setter for this property? If so, simply adjust its + visibility if necessary. + } + if assigned(orgaccesspd) then + parentpd:=orgaccesspd + else + parentpd:=tprocdef(tprocsym(sym).procdeflist[0]); + if parentpd.owner.defowner=owner.defowner then + begin + if parentpd.visibility try to + override it } + else if parentpd.visibility<>vis_private then + begin + if po_virtualmethod in parentpd.procoptions then + begin + procoptions:=procoptions+[po_virtualmethod,po_overridingmethod]; + if not(parentpd.synthetickind in [tsk_field_getter,tsk_field_setter]) then + Message2(parser_w_overriding_property_getter_setter,accessorname,FullTypeName(tdef(parentpd.owner.defowner),nil)); + end; + { otherwise we can't do anything, and + proc_add_definition will give an error } + end; + { add method with the correct visibility } + pd:=tprocdef(parentpd.getcopyas(procdef,pc_normal_no_hidden,'')); + { get rid of the import accessorname for inherited virtual class methods, + it has to be regenerated rather than amended } + if [po_classmethod,po_virtualmethod]<=pd.procoptions then + begin + stringdispose(pd.import_name); + exclude(pd.procoptions,po_has_importname); + end; + pd.visibility:=visibility; + pd.procoptions:=pd.procoptions+procoptions; + { ignore this artificially added procdef when looking for overloads } + include(pd.procoptions,po_ignore_for_overload_resolution); + finish_copied_procdef(pd,parentpd.procsym.realname,obj.symtable,obj); + exclude(pd.procoptions,po_external); + pd.synthetickind:=tsk_anon_inherited; + { set the accessor in the property } + propaccesslist[accesstyp].clear; + propaccesslist[accesstyp].addsym(sl_call,pd.procsym); + propaccesslist[accesstyp].procdef:=pd; + exit; + end; + end; + { make the artificial getter/setter virtual so we can override it in + children if necessary } + if not(sp_static in symoptions) and + (obj.typ=objectdef) then + include(procoptions,po_virtualmethod); + { prevent problems in Delphi mode } + include(procoptions,po_overload); + end + else + begin + { construct procsym accessorname (unique for this access; reusing the same + helper for multiple accesses to the same field is hard because the + propacesslist can contain subscript nodes etc) } + accessorname:=visibilityName[visibility]; + replace(accessorname,' ','_'); + if getter then + accessorname:=accessorname+'$getter' + else + accessorname:=accessorname+'$setter'; + end; + + { create procdef } + if not assigned(orgaccesspd) then + begin + pd:=cprocdef.create(normal_function_level,true); + if df_generic in obj.defoptions then + include(pd.defoptions,df_generic); + { method of this objectdef } + pd.struct:=obj; + { can only construct the artificial accessorname now, because it requires + pd.unique_id_str } + if not explicitwrapper then + accessorname:='$'+obj.symtable.realname^+'$'+realname+'$'+accessorname+'$'+pd.unique_id_str; + end + else + begin + { getter/setter could have parameters in case of indexed access + -> copy original procdef } + pd:=tprocdef(orgaccesspd.getcopyas(procdef,pc_normal_no_hidden,'')); + exclude(pd.procoptions,po_abstractmethod); + exclude(pd.procoptions,po_overridingmethod); + { can only construct the artificial accessorname now, because it requires + pd.unique_id_str } + if not explicitwrapper then + accessorname:='$'+obj.symtable.realname^+'$'+realname+'$'+accessorname+'$'+pd.unique_id_str; + finish_copied_procdef(pd,accessorname,obj.symtable,obj); + sym:=pd.procsym; + end; + { add previously collected procoptions } + pd.procoptions:=pd.procoptions+procoptions; + { visibility } + pd.visibility:=visibility; + + { new procsym? } + if not assigned(sym) or + (sym.owner<>owner) then + begin + ps:=cprocsym.create(accessorname); + obj.symtable.insert(ps); + end + else + ps:=tprocsym(sym); + { associate procsym with procdef} + pd.procsym:=ps; + + { function/procedure } + accessorparapd:=nil; + if getter then + begin + pd.proctypeoption:=potype_function; + pd.synthetickind:=tsk_field_getter; + { result type } + pd.returndef:=propdef; + if (ppo_hasparameters in propoptions) and + not assigned(orgaccesspd) then + accessorparapd:=pd; + end + else + begin + pd.proctypeoption:=potype_procedure; + pd.synthetickind:=tsk_field_setter; + pd.returndef:=voidtype; + if not assigned(orgaccesspd) then + begin + { parameter with value to set } + pvs:=cparavarsym.create('__fpc_newval__',10,vs_const,propdef,[]); + pd.parast.insert(pvs); + end; + if (ppo_hasparameters in propoptions) and + not assigned(orgaccesspd) then + accessorparapd:=pd; + end; + + { create a property for the old symaccesslist with a new accessorname, so that + we can reuse it in the implementation (rather than having to + translate the symaccesslist back to Pascal code) } + callthroughpropname:='__fpc__'+realname; + if getter then + callthroughpropname:=callthroughpropname+'__getter_wrapper' + else + callthroughpropname:=callthroughpropname+'__setter_wrapper'; + callthroughprop:=cpropertysym.create(callthroughpropname); + callthroughprop.visibility:=visibility; + + if getter then + makeduplicate(callthroughprop,accessorparapd,nil,paranr) + else + makeduplicate(callthroughprop,nil,accessorparapd,paranr); + + callthroughprop.default:=longint($80000000); + callthroughprop.default:=0; + callthroughprop.propoptions:=callthroughprop.propoptions-[ppo_stored,ppo_enumerator_current,ppo_overrides,ppo_defaultproperty]; + if sp_static in symoptions then + include(callthroughprop.symoptions, sp_static); + { copy original property target to callthrough property (and replace + original one with the new empty list; will be filled in later) } + tmpaccesslist:=callthroughprop.propaccesslist[accesstyp]; + callthroughprop.propaccesslist[accesstyp]:=propaccesslist[accesstyp]; + propaccesslist[accesstyp]:=tmpaccesslist; + owner.insert(callthroughprop); + + pd.skpara:=callthroughprop; + { needs to be exported } + include(pd.procoptions,po_global); + { class property -> static class method } + if sp_static in symoptions then + pd.procoptions:=pd.procoptions+[po_classmethod,po_staticmethod]; + + { in case we made a copy of the original accessor, this has all been + done already } + if not assigned(orgaccesspd) then + begin + { calling convention } + handle_calling_convention(pd,hcc_default_actions_intf_struct); + { register forward declaration with procsym } + proc_add_definition(pd); + end; + + { make the property call this new function } + propaccesslist[accesstyp].addsym(sl_call,ps); + propaccesslist[accesstyp].procdef:=pd; + finally + symtablestack.pop(obj.symtable); + end; + end; + + + procedure tcpupropertysym.finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef); + var + orgaccesspd: tprocdef; + pprefix: pshortstring; + wrongvisibility: boolean; + begin + inherited; + if getset=palt_read then + pprefix:=@prop_auto_getter_prefix + else + pprefix:=@prop_auto_setter_prefix; + case sym.typ of + procsym: + begin + orgaccesspd:=tprocdef(propaccesslist[getset].procdef); + wrongvisibility:=tprocdef(propaccesslist[getset].procdef).visibility'') and + (sym.RealName<>pprefix^+RealName)) then + create_getter_or_setter_for_property(orgaccesspd,getset=palt_read) + end; + fieldvarsym: + begin + { if the visibility of the field is lower than the + visibility of the property, wrap it in a getter + so that we can access it from all contexts in + which the property is visibile } + if (pprefix^<>'') or + (tfieldvarsym(sym).visibility=visibility then + exit; + end; + fieldvarsym: + begin + if sym.visibility>=visibility then + exit; + accessordef:=nil; + end; + else + internalerror(2014061102); + end; + propaccesslist[getset]:=psym.propaccesslist[getset].getcopy; + finalize_getter_or_setter_for_sym(getset,sym,propdef,accessordef); + end; + + + procedure tcpupropertysym.inherit_accessor(getset: tpropaccesslisttypes); + begin + inherited; + { new property has higher visibility than previous one -> maybe override + the getters/setters } + if assigned(overriddenpropsym) and + (overriddenpropsym.visibility store common part: method(parametertypes)returntype and + adorn as required when using it. + } + if not signature then + begin + { method name } + { special names for constructors and class constructors } + if proctypeoption=potype_constructor then + tmpresult:='' + else if proctypeoption in [potype_class_constructor,potype_unitinit] then + tmpresult:='' + else if po_has_importname in procoptions then + begin + if assigned(import_name) then + tmpresult:=import_name^ + else + internalerror(2010122608); + end + else + begin + tmpresult:=procsym.realname; + if tmpresult[1]='$' then + tmpresult:=copy(tmpresult,2,length(tmpresult)-1); + { nested functions } + container:=owner; + while container.symtabletype=localsymtable do + begin + tmpresult:='$'+tprocdef(owner.defowner).procsym.realname+'$$'+tprocdef(owner.defowner).unique_id_str+'$'+tmpresult; + container:=container.defowner.owner; + end; + end; + end + else + tmpresult:=''; + { parameter types } + tmpresult:=tmpresult+'('; + { not the case for the main program (not required for defaultmangledname + because setmangledname() is called for the main program; in case of + the JVM, this only sets the importname, however) } + if assigned(paras) then + begin + for i:=0 to paras.count-1 do + begin + vs:=tparavarsym(paras[i]); + { function result is not part of the mangled name } + if vo_is_funcret in vs.varoptions then + continue; + { self pointer neither, except for class methods (the JVM only + supports static class methods natively, so the self pointer + here is a regular parameter as far as the JVM is concerned } + if not(po_classmethod in procoptions) and + (vo_is_self in vs.varoptions) then + continue; + { passing by reference is emulated by passing an array of one + element containing the value; for types that aren't pointers + in regular Pascal, simply passing the underlying pointer type + does achieve regular call-by-reference semantics though; + formaldefs always have to be passed like that because their + contents can be replaced } + if paramanager.push_copyout_param(vs.varspez,vs.vardef,proccalloption) then + tmpresult:=tmpresult+'['; + { Add the parameter type. } + { todo: WASM + if not jvmaddencodedtype(vs.vardef,false,tmpresult,signature,founderror) then + { an internalerror here is also triggered in case of errors in the source code } + tmpresult:=''; + } + end; + end; + tmpresult:=tmpresult+')'; + { And the type of the function result (void in case of a procedure and + constructor). } + (* todo: WASM + if (proctypeoption in [potype_constructor,potype_class_constructor]) then + jvmaddencodedtype(voidtype,false,tmpresult,signature,founderror) + else if not jvmaddencodedtype(returndef,false,tmpresult,signature,founderror) then + { an internalerror here is also triggered in case of errors in the source code } + tmpresult:=''; + *) + result:=tmpresult; + end; + + + function tcpuprocdef.mangledname: TSymStr; + begin + if _mangledname='' then + begin + result:=jvmmangledbasename(false); + if (po_has_importdll in procoptions) then + begin + { import_dll comes from "external 'import_dll_name' name 'external_name'" } + if assigned(import_dll) then + result:=import_dll^+'/'+result + else + internalerror(2010122607); + end + else + { todo: WASM + jvmaddtypeownerprefix(owner,mangledname) + } + ; + _mangledname:=result; + end + else + result:=_mangledname; + end; + + function tcpuprocdef.getfuncretsyminfo(out ressym: tsym; out resdef: tdef): boolean; + begin + { constructors don't have a result on the JVM platform } + if proctypeoption<>potype_constructor then + result:=inherited + else + result:=false; + end; + + + destructor tcpuprocdef.destroy; + begin + exprasmlist.free; + inherited destroy; + end; + +{**************************************************************************** + tcpuprocvardef +****************************************************************************} + + procedure tcpuprocvardef.ppuwrite_platform(ppufile: tcompilerppufile); + begin + inherited; + ppufile.putderef(classdefderef); + end; + + + procedure tcpuprocvardef.ppuload_platform(ppufile: tcompilerppufile); + begin + inherited; + ppufile.getderef(classdefderef); + end; + + + procedure tcpuprocvardef.buildderef; + begin + inherited buildderef; + classdefderef.build(classdef); + end; + + + procedure tcpuprocvardef.deref; + begin + inherited deref; + classdef:=tobjectdef(classdefderef.resolve); + end; + + function tcpuprocvardef.getcopy: tstoreddef; + begin + result:=inherited; + tcpuprocvardef(result).classdef:=classdef; + end; + + +{**************************************************************************** + tcpuprocsym +****************************************************************************} + + procedure tcpuprocsym.check_forward; + var + curri, checki: longint; + currpd, checkpd: tprocdef; + begin + inherited; + { check for conflicts based on mangled name, because several FPC + types/constructs map to the same JVM mangled name } + for curri:=0 to FProcdefList.Count-2 do + begin + currpd:=tprocdef(FProcdefList[curri]); + if (po_external in currpd.procoptions) or + (currpd.proccalloption=pocall_internproc) then + continue; + for checki:=curri+1 to FProcdefList.Count-1 do + begin + checkpd:=tprocdef(FProcdefList[checki]); + if po_external in checkpd.procoptions then + continue; + if currpd.mangledname=checkpd.mangledname then + begin + MessagePos(checkpd.fileinfo,parser_e_overloaded_have_same_mangled_name); + MessagePos1(currpd.fileinfo,sym_e_param_list,currpd.customprocname([pno_mangledname])); + MessagePos1(checkpd.fileinfo,sym_e_param_list,checkpd.customprocname([pno_mangledname])); + end; + end; + end; + inherited; + end; + + +{**************************************************************************** + tcpustaticvarsym +****************************************************************************} + + procedure tcpustaticvarsym.set_mangledname(const s: TSymStr); + begin + inherited; + { todo: WASM + _mangledname:=jvmmangledbasename(self,s,false); + jvmaddtypeownerprefix(owner,_mangledname); + } + end; + + + function tcpustaticvarsym.mangledname: TSymStr; + begin + if _mangledname='' then + begin + { todo: WASM + if _mangledbasename='' then + _mangledname:=jvmmangledbasename(self,false) + else + _mangledname:=jvmmangledbasename(self,_mangledbasename,false); + jvmaddtypeownerprefix(owner,_mangledname); + } + end; + result:=_mangledname; + end; + + +{**************************************************************************** + tcpufieldvarsym +****************************************************************************} + + procedure tcpufieldvarsym.set_externalname(const s: string); + begin + { make sure it is recalculated } + cachedmangledname:=''; + if is_java_class_or_interface(tdef(owner.defowner)) then + begin + externalname:=stringdup(s); + include(varoptions,vo_has_mangledname); + end + else + internalerror(2011031201); + end; + + + function tcpufieldvarsym.mangledname: TSymStr; + begin + if is_java_class_or_interface(tdef(owner.defowner)) or + (tdef(owner.defowner).typ=recorddef) then + begin + if cachedmangledname<>'' then + result:=cachedmangledname + else + begin + { todo: WASM + result:=jvmmangledbasename(self,false); + jvmaddtypeownerprefix(owner,result); + } + cachedmangledname:=result; + end; + end + else + result:=inherited; + end; + +begin + { used tdef classes } + cfiledef:=tcpufiledef; + cvariantdef:=tcpuvariantdef; + cformaldef:=tcpuformaldef; + cforwarddef:=tcpuforwarddef; + cundefineddef:=tcpuundefineddef; + cerrordef:=tcpuerrordef; + cpointerdef:=tcpupointerdef; + crecorddef:=tcpurecorddef; + cimplementedinterface:=tcpuimplementedinterface; + cobjectdef:=tcpuobjectdef; + cclassrefdef:=tcpuclassrefdef; + carraydef:=tcpuarraydef; + corddef:=tcpuorddef; + cfloatdef:=tcpufloatdef; + cprocvardef:=tcpuprocvardef; + cprocdef:=tcpuprocdef; + cstringdef:=tcpustringdef; + cenumdef:=tcpuenumdef; + csetdef:=tcpusetdef; + + { used tsym classes } + clabelsym:=tcpulabelsym; + cunitsym:=tcpuunitsym; + cprogramparasym:=tcpuprogramparasym; + cnamespacesym:=tcpunamespacesym; + cprocsym:=tcpuprocsym; + ctypesym:=tcputypesym; + cfieldvarsym:=tcpufieldvarsym; + clocalvarsym:=tcpulocalvarsym; + cparavarsym:=tcpuparavarsym; + cstaticvarsym:=tcpustaticvarsym; + cabsolutevarsym:=tcpuabsolutevarsym; + cpropertysym:=tcpupropertysym; + cconstsym:=tcpuconstsym; + cenumsym:=tcpuenumsym; + csyssym:=tcpusyssym; +end. + diff --git a/compiler/wasm/wasmdef.pas b/compiler/wasm/wasmdef.pas new file mode 100644 index 0000000000..23d1f0c458 --- /dev/null +++ b/compiler/wasm/wasmdef.pas @@ -0,0 +1,58 @@ +unit wasmdef; + +interface + +uses + symtype, symdef, symconst, constexp + ,defutil; + + { returns whether a def is emulated using an implicit pointer type on the + WebAssembly target (e.g., records, regular arrays, ...) } + function wasmimplicitpointertype(def: tdef): boolean; + + function get_para_push_size(def: tdef): tdef; + +implementation + + function get_para_push_size(def: tdef): tdef; + begin + result:=def; + if def.typ=orddef then + case torddef(def).ordtype of + u8bit,uchar: + if torddef(def).high>127 then + result:=s8inttype; + u16bit: + begin + if torddef(def).high>32767 then + result:=s16inttype; + end + else + ; + end; + end; + + function wasmimplicitpointertype(def: tdef): boolean; + begin + case def.typ of + arraydef: + result:=(tarraydef(def).highrange>=tarraydef(def).lowrange) or + is_open_array(def) or + is_array_of_const(def) or + is_array_constructor(def); + filedef, + recorddef, + setdef: + result:=true; + objectdef: + result:=is_object(def); + stringdef : + result:=tstringdef(def).stringtype in [st_shortstring,st_longstring]; + procvardef: + result:=not tprocvardef(def).is_addressonly; + else + result:=false; + end; + end; + +end. diff --git a/compiler/wasm/wasmreg.dat b/compiler/wasm/wasmreg.dat new file mode 100644 index 0000000000..739feff3fa --- /dev/null +++ b/compiler/wasm/wasmreg.dat @@ -0,0 +1,20 @@ +; +; WebAssembly registers +; +; layout +; ,,,, +; +; The JVM does not have any registers, since it is stack-based. +; We do define a few artificial registers to make integration +; with the rest of the compiler easier though. + +; general/int registers +NO,$00,$00,$00,INVALID +; used as base register in reference when referring to the top +; of the evaluation stack (offset = offset on the evaluation +; stack) +R0,$01,$00,$00,evalstacktopptr +; for addressing locals ("stack pointer") +R1,$01,$00,$01,localsstackptr +; generic fake evaluation stack register for use by the register allocator +R2,$01,$00,$02,evalstacktop