[PATCH 03/83] adding WASM specific files

From 3e72f04bc65f3da24efdf55a3102ef21479ff567 Mon Sep 17 00:00:00 2001
From: Dmitry Boyarintsev <[email protected]>
Date: Wed, 28 Aug 2019 17:01:46 -0400

git-svn-id: branches/wasm@45880 -

.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

compiler/systems/t_wasm.pas

@@ -0,0 +1,7 @@
+unit t_wasm;
+
+interface
+
+implementation
+
+end.

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<p then
+            break;
+          dec(i,p);
+        until false;
+      end;
+    p:=p shr 1;
+  until p=0;
+end;
+
+procedure build_std_regname_index;
+
+var h,i,j,p,t:byte;
+
+begin
+  {Build the registernumber2regindex index.
+   Step 1: Fill.}
+  for i:=0 to regcount-1 do
+    std_regname_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 stdnames[std_regname_index[j]]>=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<p then
+            break;
+          dec(i,p);
+        until false;
+      end;
+    p:=p shr 1;
+  until p=0;
+end;
+
+
+procedure read_spreg_file;
+
+var infile:text;
+
+begin
+   { open dat file }
+   assign(infile,'wasmreg.dat');
+   reset(infile);
+   while not(eof(infile)) do
+     begin
+        { handle comment }
+        readln(infile,s);
+        inc(line);
+        while (s[1]=' ') do
+         delete(s,1,1);
+        if (s='') or (s[1]=';') then
+          continue;
+
+        i:=1;
+        names[regcount]:=readstr;
+        readcomma;
+        regtypes[regcount]:=readstr;
+        readcomma;
+        subtypes[regcount]:=readstr;
+        readcomma;
+        supregs[regcount]:=readstr;
+        readcomma;
+        stdnames[regcount]:=readstr;
+        { Create register number }
+        if supregs[regcount][1]<>'$' 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 i<length(s) then
+          begin
+            writeln('Extra chars at end of line, at line ',line);
+            writeln('Line: "',s,'"');
+            halt(1);
+          end;
+        inc(regcount);
+        if regcount>max_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_bsstart<regcount do
+     regcount_bsstart:=regcount_bsstart*2;
+   build_regnum_index;
+   build_std_regname_index;
+   write_inc_files;
+end.

compiler/wasm/aasmcpu.pas

@@ -0,0 +1,301 @@
+{
+    Copyright (c) 2019 by Free Pascal and Lazarus foundation
+
+    Contains the assembler object 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 aasmcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  cclasses,
+  globtype,globals,verbose,
+  aasmbase,aasmtai,aasmdata,aasmsym,
+  cgbase,cgutils,cpubase,cpuinfo,
+  widestr;
+
+    { fake, there are no "mov reg,reg" instructions here }
+    const
+      { "mov reg,reg" source operand number }
+      O_MOV_SOURCE = 0;
+      { "mov reg,reg" source operand number }
+      O_MOV_DEST = 0;
+
+    type
+
+      { taicpu }
+
+      taicpu = class(tai_cpu_abstract_sym)
+         constructor op_none(op : tasmop);
+
+         constructor op_reg(op : tasmop;_op1 : tregister);
+         constructor op_const(op : tasmop;_op1 : aint);
+         constructor op_ref(op : tasmop;const _op1 : treference);
+         constructor op_sym(op : tasmop;_op1 : tasmsymbol);
+
+         constructor op_sym_const(op : tasmop;_op1 : tasmsymbol;_op2 : aint);
+
+         constructor op_single(op : tasmop;_op1 : single);
+         constructor op_double(op : tasmop;_op1 : double);
+         //constructor op_string(op : tasmop;_op1len : aint;_op1 : pchar);
+         //constructor op_wstring(op : tasmop;_op1 : pcompilerwidestring);
+
+         procedure loadsingle(opidx:longint;f:single);
+         procedure loaddouble(opidx:longint;d:double);
+         //procedure loadstr(opidx:longint;vallen: aint;pc: pchar);
+         //procedure loadpwstr(opidx:longint;pwstr:pcompilerwidestring);
+
+
+         { register allocation }
+         function is_same_reg_move(regtype: Tregistertype):boolean; override;
+
+         { register spilling code }
+         function spilling_get_operation_type(opnr: longint): topertype;override;
+      end;
+
+      tai_align = class(tai_align_abstract)
+        { nothing to add }
+      end;
+
+    procedure InitAsm;
+    procedure DoneAsm;
+
+    function spilling_create_load(const ref:treference;r:tregister):Taicpu;
+    function spilling_create_store(r:tregister; const ref:treference):Taicpu;
+
+implementation
+
+{*****************************************************************************
+                                 taicpu Constructors
+*****************************************************************************}
+
+    constructor taicpu.op_none(op : tasmop);
+      begin
+        inherited create(op);
+      end;
+
+
+    constructor taicpu.op_reg(op : tasmop;_op1 : tregister);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadreg(0,_op1);
+      end;
+
+
+    constructor taicpu.op_ref(op : tasmop;const _op1 : treference);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadref(0,_op1);
+      end;
+
+
+    constructor taicpu.op_const(op : tasmop;_op1 : aint);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadconst(0,_op1);
+      end;
+
+
+    constructor taicpu.op_sym(op : tasmop;_op1 : tasmsymbol);
+      begin
+        inherited create(op);
+        ops:=1;
+        is_jmp:=op in [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_goto];
+        loadsymbol(0,_op1,0);
+      end;
+
+
+    constructor taicpu.op_sym_const(op: tasmop; _op1: tasmsymbol; _op2: aint);
+      begin
+        inherited create(op);
+        ops:=2;
+        loadsymbol(0,_op1,0);
+        loadconst(1,_op2);
+      end;
+
+
+    constructor taicpu.op_single(op: tasmop; _op1: single);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadsingle(0,_op1);
+      end;
+
+
+    constructor taicpu.op_double(op: tasmop; _op1: double);
+      begin
+        inherited create(op);
+        ops:=1;
+        loaddouble(0,_op1);
+      end;
+
+    {constructor taicpu.op_string(op: tasmop; _op1len: aint; _op1: pchar);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadstr(0,_op1len,_op1);
+      end;
+
+    constructor taicpu.op_wstring(op: tasmop; _op1: pcompilerwidestring);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadpwstr(0,_op1);
+      end;}
+
+
+    procedure taicpu.loadsingle(opidx:longint;f:single);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           if typ<>top_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.

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.

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.

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.

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.

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.

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.

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:
+            <incoming parameters>
+          sp+first_temp_offset:
+            <locals>
+            <temp>
+        }
+        procdef.init_paraloc_info(calleeside);
+        tg.setfirsttemp(procdef.calleeargareasize);
+      end;
+
+
+begin
+  cprocinfo:=tcpuprocinfo;
+end.

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.

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.

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.

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

compiler/wasm/rwasmnor.inc

@@ -0,0 +1,2 @@
+{ don't edit, this file is generated from wasmreg.dat }
+4

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)

compiler/wasm/rwasmrni.inc

@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from wasmreg.dat }
+0,
+1,
+2,
+3

compiler/wasm/rwasmsri.inc

@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from wasmreg.dat }
+0,
+3,
+1,
+2

compiler/wasm/rwasmstd.inc

@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from wasmreg.dat }
+'INVALID',
+'evalstacktopptr',
+'localsstackptr',
+'evalstacktop'

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;

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<visibility then
+                          begin
+                            parentpd.visibility:=visibility;
+                            include(parentpd.procoptions,po_auto_raised_visibility);
+                          end;
+                        { we are done, no need to create a wrapper }
+                        exit
+                      end
+                    { a parent already included this getter/setter -> 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<visibility;
+            { if the visibility of the accessor is lower than
+              the visibility of the property, wrap it so that
+              we can call it from all contexts in which the
+              property is visible }
+            if wrongvisibility or
+               ((pprefix^<>'') 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
+              create_getter_or_setter_for_property(nil,getset=palt_read);
+          end;
+        else
+          internalerror(2014061101);
+      end;
+    end;
+
+
+  procedure tcpupropertysym.maybe_create_overridden_getter_or_setter(getset: tpropaccesslisttypes);
+    var
+      sym: tsym;
+      accessordef: tprocdef;
+      psym: tpropertysym;
+    begin
+      { find the last defined getter/setter/field accessed by an inherited
+        property }
+      psym:=overriddenpropsym;
+      while not assigned(psym.propaccesslist[getset].firstsym) do
+        begin
+          psym:=psym.overriddenpropsym;
+          { if there is simply no getter/setter for this property, we're done }
+          if not assigned(psym) then
+            exit;
+        end;
+      sym:=psym.propaccesslist[getset].firstsym^.sym;
+      case sym.typ of
+        procsym:
+          begin
+            accessordef:=tprocdef(psym.propaccesslist[getset].procdef);
+            if accessordef.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<visibility) then
+        maybe_create_overridden_getter_or_setter(getset);
+    end;
+
+
+{****************************************************************************
+                             tcpuenumdef
+****************************************************************************}
+
+  procedure tcpuenumdef.ppuload_platform(ppufile: tcompilerppufile);
+    begin
+      inherited;
+      ppufile.getderef(classdefderef);
+    end;
+
+
+  procedure tcpuenumdef.ppuwrite_platform(ppufile: tcompilerppufile);
+    begin
+      inherited;
+      ppufile.putderef(classdefderef);
+    end;
+
+
+  function tcpuenumdef.getcopy: tstoreddef;
+    begin
+      result:=inherited;
+      tcpuenumdef(result).classdef:=classdef;
+    end;
+
+
+  procedure tcpuenumdef.buildderef;
+    begin
+      inherited;
+      classdefderef.build(classdef);
+    end;
+
+
+  procedure tcpuenumdef.deref;
+    begin
+      inherited;
+      classdef:=tobjectdef(classdefderef.resolve);
+    end;
+
+{****************************************************************************
+                             tcpuprocdef
+****************************************************************************}
+
+  function tcpuprocdef.jvmmangledbasename(signature: boolean): TSymStr;
+  var
+    vs: tparavarsym;
+    i: longint;
+    founderror: tdef;
+    tmpresult: TSymStr;
+    container: tsymtable;
+  begin
+    { format:
+        * method definition (in Jasmin):
+            (private|protected|public) [static] method(parametertypes)returntype
+        * method invocation
+            package/class/method(parametertypes)returntype
+      -> 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:='<init>'
+        else if proctypeoption in [potype_class_constructor,potype_unitinit] then
+          tmpresult:='<clinit>'
+        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:='<error>';
+              }
+          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:='<error>';
+      *)
+    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.
+

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.

compiler/wasm/wasmreg.dat

@@ -0,0 +1,20 @@
+;
+; WebAssembly registers
+;
+; layout
+; <name>,<type>,<subtype>,<value>,<stdname>
+;
+; 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