paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 07:47:59 +02:00
Code Issues Packages Projects Releases Wiki Activity

[PATCH 03/83] adding WASM specific files

Browse Source 
From 3e72f04bc65f3da24efdf55a3102ef21479ff567 Mon Sep 17 00:00:00 2001
From: Dmitry Boyarintsev <skalogryz.lists@gmail.com>
Date: Wed, 28 Aug 2019 17:01:46 -0400

git-svn-id: branches/wasm@45880 -
This commit is contained in:
nickysn 2020-07-29 16:06:57 +00:00
parent 95bed362ba
commit 184c559496
24 changed files with 5791 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
.gitattributes vendored
View File

@ -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

7
compiler/systems/t_wasm.pas Normal file
View File

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

265
compiler/utils/mkwasmreg.pp Normal file
View File

@ -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.

301
compiler/wasm/aasmcpu.pas Normal file
View File

@ -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.

30
compiler/wasm/agwat.pas Normal file
View File

@ -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.

129
compiler/wasm/cgcpu.pas Normal file
View File

@ -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.

358
compiler/wasm/cpubase.pas Normal file
View File

@ -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.

107
compiler/wasm/cpuinfo.pas Normal file
View File

@ -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.

45
compiler/wasm/cpunode.pas Normal file
View File

@ -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.

329
compiler/wasm/cpupara.pas Normal file
View File

@ -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.

65
compiler/wasm/cpupi.pas Normal file
View File

@ -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.

64
compiler/wasm/cputarg.pas Normal file
View File

@ -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.

2587
compiler/wasm/hlcgcpu.pas Normal file
View File

File diff suppressed because it is too large Load Diff

417
compiler/wasm/rgcpu.pas Normal file
View File

@ -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.

5
compiler/wasm/rwasmcon.inc Normal file
View File

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

2
compiler/wasm/rwasmnor.inc Normal file
View File

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

5
compiler/wasm/rwasmnum.inc Normal file
View File

@ -0,0 +1,5 @@
{ don't edit, this file is generated from wasmreg.dat }
tregister($00000000),
tregister($01000000),
tregister($01000001),
tregister($01000002)

5
compiler/wasm/rwasmrni.inc Normal file
View File

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

5
compiler/wasm/rwasmsri.inc Normal file
View File

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

5
compiler/wasm/rwasmstd.inc Normal file
View File

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

5
compiler/wasm/rwasmsup.inc Normal file
View File

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

954
compiler/wasm/symcpu.pas Normal file
View File

@ -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.

58
compiler/wasm/wasmdef.pas Normal file
View File

@ -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.

20
compiler/wasm/wasmreg.dat Normal file
View File

@ -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