summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorflorian <florian@3ad0048d-3df7-0310-abae-a5850022a9f2>2014-04-06 12:49:38 +0000
committerflorian <florian@3ad0048d-3df7-0310-abae-a5850022a9f2>2014-04-06 12:49:38 +0000
commitc31849d95470a761adb8c76f563baf26e6ae7bcd (patch)
tree250428351814b3b897beddd084fac97b79f316c3
parent87496a06da21831d719eabd81808523542f1d809 (diff)
downloadfpc-js.tar.gz
+ initial skeleton of the js backendjs
git-svn-id: http://svn.freepascal.org/svn/fpc/branches/js@27484 3ad0048d-3df7-0310-abae-a5850022a9f2
-rw-r--r--compiler/agjs.pas1233
-rw-r--r--compiler/fpcdefs.inc9
-rw-r--r--compiler/globals.pas5
-rw-r--r--compiler/js/aasmcpu.pas304
-rw-r--r--compiler/js/cgcpu.pas129
-rw-r--r--compiler/js/cpubase.pas338
-rw-r--r--compiler/js/cpuinfo.pas75
-rw-r--r--compiler/js/cpunode.pas38
-rw-r--r--compiler/js/cpupara.pas306
-rw-r--r--compiler/js/cpupi.pas65
-rw-r--r--compiler/js/cputarg.pas58
-rw-r--r--compiler/js/hlcgcpu.pas64
-rw-r--r--compiler/js/rgcpu.pas358
-rw-r--r--compiler/js/rjscon.inc5
-rw-r--r--compiler/js/rjsnor.inc2
-rw-r--r--compiler/js/rjsnum.inc5
-rw-r--r--compiler/js/rjsrni.inc5
-rw-r--r--compiler/js/rjssri.inc5
-rw-r--r--compiler/js/rjsstd.inc5
-rw-r--r--compiler/js/rjssup.inc5
-rw-r--r--compiler/js/symcpu.pas211
-rw-r--r--compiler/js/tgcpu.pas261
-rw-r--r--compiler/pp.pas6
-rw-r--r--compiler/ppcjs.lpi74
-rw-r--r--compiler/systems.inc1
-rw-r--r--compiler/utils/mkjsreg.pp265
26 files changed, 3831 insertions, 1 deletions
diff --git a/compiler/agjs.pas b/compiler/agjs.pas
new file mode 100644
index 0000000000..f1e2d2d1fd
--- /dev/null
+++ b/compiler/agjs.pas
@@ -0,0 +1,1233 @@
+{
+ Copyright (c) 1998-2010 by the Free Pascal team
+
+ This unit implements the Jasmin assembler 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 JS (JVM bytecode) output.
+}
+unit agjs;
+
+{$i fpcdefs.inc}
+
+interface
+
+ uses
+ cclasses,
+ globtype,globals,
+ symconst,symbase,symdef,symsym,
+ aasmbase,aasmtai,aasmdata,aasmcpu,
+ assemble;
+
+ type
+ TJSInstrWriter = class;
+ { This is a derived class which is used to write
+ JS
+ }
+
+ TJSAssembler=class(texternalassembler)
+ protected
+ jasminjar: tcmdstr;
+ asmfiles: TCmdStrList;
+
+ procedure WriteExtraHeader(obj: tabstractrecorddef);
+ procedure WriteInstruction(hp: tai);
+ procedure NewAsmFileForStructDef(obj: tabstractrecorddef);
+
+ function VisibilityToStr(vis: tvisibility): ansistring;
+ function MethodDefinition(pd: tprocdef): ansistring;
+ function ConstValue(csym: tconstsym): ansistring;
+ function ConstAssignmentValue(csym: tconstsym): ansistring;
+ function ConstDefinition(sym: tconstsym): ansistring;
+ function FieldDefinition(sym: tabstractvarsym): ansistring;
+ function InnerStructDef(obj: tabstractrecorddef): ansistring;
+
+ procedure WriteProcDef(pd: tprocdef);
+ procedure WriteFieldSym(sym: tabstractvarsym);
+ procedure WriteConstSym(sym: tconstsym);
+ procedure WriteSymtableVarSyms(st: TSymtable);
+ procedure WriteSymtableProcdefs(st: TSymtable);
+ procedure WriteSymtableStructDefs(st: TSymtable);
+ public
+ constructor Create(smart: boolean); override;
+ function MakeCmdLine: TCmdStr;override;
+ procedure WriteTree(p:TAsmList);override;
+ procedure WriteAsmList;override;
+ procedure RemoveAsm; override;
+ destructor destroy; override;
+ protected
+ InstrWriter: TJSInstrWriter;
+ end;
+
+
+ { This is the base class for writing instructions.
+
+ The WriteInstruction() method must be overridden
+ to write a single instruction to the assembler
+ file.
+ }
+ TJSInstrWriter = class
+ constructor create(_owner: TJSAssembler);
+ procedure WriteInstruction(hp : tai); virtual;
+ protected
+ owner: TJSAssembler;
+ end;
+
+
+implementation
+
+ uses
+ SysUtils,
+ cutils,cfileutl,systems,script,
+ fmodule,finput,verbose,
+ symtype,symtable,
+ cpubase,cpuinfo,cgutils,
+ widestr
+ ;
+
+ const
+ line_length = 70;
+
+ type
+ t64bitarray = array[0..7] of byte;
+ t32bitarray = array[0..3] of byte;
+
+{****************************************************************************}
+{ Support routines }
+{****************************************************************************}
+
+ function fixline(s:string):string;
+ {
+ return s with all leading and ending spaces and tabs removed
+ }
+ var
+ i,j,k : integer;
+ begin
+ i:=length(s);
+ while (i>0) and (s[i] in [#9,' ']) do
+ dec(i);
+ j:=1;
+ while (j<i) and (s[j] in [#9,' ']) do
+ inc(j);
+ for k:=j to i do
+ if s[k] in [#0..#31,#127..#255] then
+ s[k]:='.';
+ fixline:=Copy(s,j,i-j+1);
+ end;
+
+
+ function constastr(p: pchar; len: longint): ansistring;
+ var
+ i,runstart,runlen: longint;
+
+ procedure flush;
+ begin
+ if runlen>0 then
+ begin
+ setlength(result,length(result)+runlen);
+ move(p[runstart],result[length(result)-runlen+1],runlen);
+ runlen:=0;
+ end;
+ end;
+
+ begin
+ result:='"';
+ runlen:=0;
+ runstart:=0;
+ for i:=0 to len-1 do
+ begin
+ { escape control codes }
+ case p[i] of
+ { LF and CR must be escaped specially, because \uXXXX parsing
+ happens in the pre-processor, so it's the same as actually
+ inserting a newline in the middle of a string constant }
+ #10:
+ begin
+ flush;
+ result:=result+'\n';
+ end;
+ #13:
+ begin
+ flush;
+ result:=result+'\r';
+ end;
+ '"','\':
+ begin
+ flush;
+ result:=result+'\'+p[i];
+ end
+ else if p[i]<#32 then
+ begin
+ flush;
+ result:=result+'\u'+hexstr(ord(p[i]),4);
+ end
+ else if p[i]<#127 then
+ begin
+ if runlen=0 then
+ runstart:=i;
+ inc(runlen);
+ end
+ else
+ begin
+ { see comments in njvmcon }
+ flush;
+ result:=result+'\u'+hexstr(ord(p[i]),4)
+ end;
+ end;
+ end;
+ flush;
+ result:=result+'"';
+ end;
+
+
+ function constwstr(w: pcompilerwidechar; len: longint): ansistring;
+ var
+ i: longint;
+ begin
+ result:='"';
+ for i:=0 to len-1 do
+ begin
+ { escape control codes }
+ case w[i] of
+ 10:
+ result:=result+'\n';
+ 13:
+ result:=result+'\r';
+ ord('"'),ord('\'):
+ result:=result+'\'+chr(w[i]);
+ else if (w[i]<32) or
+ (w[i]>=127) then
+ result:=result+'\u'+hexstr(w[i],4)
+ else
+ result:=result+char(w[i]);
+ end;
+ end;
+ result:=result+'"';
+ end;
+
+
+ function constsingle(s: single): ansistring;
+ begin
+ result:='0fx'+hexstr(longint(t32bitarray(s)),8);
+ end;
+
+
+ function constdouble(d: double): ansistring;
+ begin
+ // force interpretation as double (since we write it out as an
+ // integer, we never have to swap the endianess). We have to
+ // include the sign separately because of the way Java parses
+ // hex numbers (0x8000000000000000 is not a valid long)
+ result:=hexstr(abs(int64(t64bitarray(d))),16);
+ if int64(t64bitarray(d))<0 then
+ result:='-'+result;
+ result:='0dx'+result;
+ end;
+
+{****************************************************************************}
+{ Jasmin Assembler writer }
+{****************************************************************************}
+
+ destructor TJSAssembler.Destroy;
+ begin
+ InstrWriter.free;
+ asmfiles.free;
+ inherited destroy;
+ end;
+
+
+ procedure TJSAssembler.WriteTree(p:TAsmList);
+ var
+ ch : char;
+ hp : tai;
+ hp1 : tailineinfo;
+ s : ansistring;
+ i,pos : longint;
+ InlineLevel : longint;
+ do_line : boolean;
+ begin
+ if not assigned(p) then
+ exit;
+
+ InlineLevel:=0;
+ { lineinfo is only needed for al_procedures (PFV) }
+ do_line:=(cs_asm_source in current_settings.globalswitches);
+ hp:=tai(p.first);
+ while assigned(hp) do
+ begin
+ prefetch(pointer(hp.next)^);
+ if not(hp.typ in SkipLineInfo) then
+ begin
+ hp1 := hp as tailineinfo;
+ current_filepos:=hp1.fileinfo;
+ { no line info for inlined code }
+ if do_line and (inlinelevel=0) then
+ begin
+ { load infile }
+ if lastfileinfo.fileindex<>hp1.fileinfo.fileindex then
+ begin
+ infile:=current_module.sourcefiles.get_file(hp1.fileinfo.fileindex);
+ if assigned(infile) then
+ begin
+ { open only if needed !! }
+ if (cs_asm_source in current_settings.globalswitches) then
+ infile.open;
+ end;
+ { avoid unnecessary reopens of the same file !! }
+ lastfileinfo.fileindex:=hp1.fileinfo.fileindex;
+ { be sure to change line !! }
+ lastfileinfo.line:=-1;
+ end;
+
+ { write source }
+ if (cs_asm_source in current_settings.globalswitches) and
+ assigned(infile) then
+ begin
+ if (infile<>lastinfile) then
+ begin
+ AsmWriteLn(target_asm.comment+'['+infile.name+']');
+ if assigned(lastinfile) then
+ lastinfile.close;
+ end;
+ if (hp1.fileinfo.line<>lastfileinfo.line) and
+ ((hp1.fileinfo.line<infile.maxlinebuf) or (InlineLevel>0)) then
+ begin
+ if (hp1.fileinfo.line<>0) and
+ ((infile.linebuf^[hp1.fileinfo.line]>=0) or (InlineLevel>0)) then
+ AsmWriteLn(target_asm.comment+'['+tostr(hp1.fileinfo.line)+'] '+
+ fixline(infile.GetLineStr(hp1.fileinfo.line)));
+ { set it to a negative value !
+ to make that is has been read already !! PM }
+ if (infile.linebuf^[hp1.fileinfo.line]>=0) then
+ infile.linebuf^[hp1.fileinfo.line]:=-infile.linebuf^[hp1.fileinfo.line]-1;
+ end;
+ end;
+ lastfileinfo:=hp1.fileinfo;
+ lastinfile:=infile;
+ end;
+ end;
+
+ case hp.typ of
+
+ ait_comment :
+ Begin
+ AsmWrite(target_asm.comment);
+ AsmWritePChar(tai_comment(hp).str);
+ AsmLn;
+ End;
+
+ ait_regalloc :
+ begin
+ if (cs_asm_regalloc in current_settings.globalswitches) then
+ begin
+ AsmWrite(#9+target_asm.comment+'Register ');
+ repeat
+ AsmWrite(std_regname(Tai_regalloc(hp).reg));
+ if (hp.next=nil) or
+ (tai(hp.next).typ<>ait_regalloc) or
+ (tai_regalloc(hp.next).ratype<>tai_regalloc(hp).ratype) then
+ break;
+ hp:=tai(hp.next);
+ AsmWrite(',');
+ until false;
+ AsmWrite(' ');
+ AsmWriteLn(regallocstr[tai_regalloc(hp).ratype]);
+ end;
+ end;
+
+ ait_tempalloc :
+ begin
+ if (cs_asm_tempalloc in current_settings.globalswitches) then
+ begin
+ {$ifdef EXTDEBUG}
+ if assigned(tai_tempalloc(hp).problem) then
+ AsmWriteLn(target_asm.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+
+ tostr(tai_tempalloc(hp).tempsize)+' '+tai_tempalloc(hp).problem^)
+ else
+ {$endif EXTDEBUG}
+ AsmWriteLn(target_asm.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+
+ tostr(tai_tempalloc(hp).tempsize)+' '+tempallocstr[tai_tempalloc(hp).allocation]);
+ end;
+ end;
+
+ ait_align :
+ begin
+
+ end;
+
+ ait_section :
+ begin
+
+ end;
+
+ ait_datablock :
+ begin
+ internalerror(2010122701);
+ end;
+
+ ait_const:
+ begin
+ AsmWriteln('constant');
+// internalerror(2010122702);
+ end;
+
+ ait_real_64bit :
+ begin
+ internalerror(2010122703);
+ end;
+
+ ait_real_32bit :
+ begin
+ internalerror(2010122703);
+ end;
+
+ ait_comp_64bit :
+ begin
+ internalerror(2010122704);
+ end;
+
+ ait_string :
+ begin
+ pos:=0;
+ for i:=1 to tai_string(hp).len do
+ begin
+ if pos=0 then
+ begin
+ AsmWrite(#9'strconst: '#9'"');
+ pos:=20;
+ end;
+ ch:=tai_string(hp).str[i-1];
+ case ch of
+ #0, {This can't be done by range, because a bug in FPC}
+ #1..#31,
+ #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7);
+ '"' : s:='\"';
+ '\' : s:='\\';
+ else
+ s:=ch;
+ end;
+ AsmWrite(s);
+ inc(pos,length(s));
+ if (pos>line_length) or (i=tai_string(hp).len) then
+ begin
+ AsmWriteLn('"');
+ pos:=0;
+ end;
+ end;
+ end;
+
+ ait_label :
+ begin
+ if (tai_label(hp).labsym.is_used) then
+ begin
+ AsmWrite(tai_label(hp).labsym.name);
+ AsmWriteLn(':');
+ end;
+ end;
+
+ ait_symbol :
+ begin
+ if (tai_symbol(hp).sym.typ = AT_FUNCTION) then
+ begin
+ end
+ else
+ begin
+ AsmWrite('data symbol: ');
+ AsmWriteln(tai_symbol(hp).sym.name);
+// internalerror(2010122706);
+ end;
+ end;
+ ait_symbol_end :
+ begin
+ end;
+
+ ait_instruction :
+ begin
+ WriteInstruction(hp);
+ end;
+
+ ait_force_line,
+ ait_function_name : ;
+
+ ait_cutobject :
+ begin
+ end;
+
+ ait_marker :
+ if tai_marker(hp).kind=mark_NoLineInfoStart then
+ inc(InlineLevel)
+ else if tai_marker(hp).kind=mark_NoLineInfoEnd then
+ dec(InlineLevel);
+
+ ait_directive :
+ begin
+ AsmWrite('.'+directivestr[tai_directive(hp).directive]+' ');
+ if tai_directive(hp).name<>'' then
+ AsmWrite(tai_directive(hp).name);
+ AsmLn;
+ end;
+
+ //ait_jvar:
+ // begin
+ // AsmWrite('.var ');
+ // AsmWrite(tostr(tai_jvar(hp).stackslot));
+ // AsmWrite(' is ');
+ // AsmWrite(tai_jvar(hp).desc^);
+ // AsmWrite(' from ');
+ // AsmWrite(tai_jvar(hp).startlab.name);
+ // AsmWrite(' to ');
+ // AsmWriteLn(tai_jvar(hp).stoplab.name);
+ // end;
+ //
+ //ait_jcatch:
+ // begin
+ // AsmWrite('.catch ');
+ // AsmWrite(tai_jcatch(hp).name^);
+ // AsmWrite(' from ');
+ // AsmWrite(tai_jcatch(hp).startlab.name);
+ // AsmWrite(' to ');
+ // AsmWrite(tai_jcatch(hp).stoplab.name);
+ // AsmWrite(' using ');
+ // AsmWriteLn(tai_jcatch(hp).handlerlab.name);
+ // end;
+ else
+ internalerror(2010122707);
+ end;
+ hp:=tai(hp.next);
+ end;
+ end;
+
+
+ procedure TJSAssembler.WriteExtraHeader(obj: tabstractrecorddef);
+ var
+ superclass,
+ intf: tobjectdef;
+ n: ansistring;
+ i: longint;
+ toplevelowner: tsymtable;
+ begin
+ { JVM 1.5+ }
+ AsmWriteLn('.bytecode 49.0');
+ // include files are not support by Java, and the directory of the main
+ // source file must not be specified
+ if current_module.mainsource<>'' then
+ n:=ExtractFileName(current_module.mainsource)
+ else
+ n:=InputFileName;
+ AsmWriteLn('.source '+ExtractFileName(n));
+
+ { class/interface name }
+ if not assigned(obj) then
+ begin
+ { fake class type for unit -> name=unitname and
+ superclass=java.lang.object, make final so you cannot descend
+ from it }
+ AsmWrite('.class final public ');
+ if assigned(current_module.namespace) then
+ AsmWrite(current_module.namespace^+'.');
+ AsmWriteln(current_module.realmodulename^);
+ AsmWriteLn('.super java/lang/Object');
+ end
+ else
+ begin
+ toplevelowner:=obj.owner;
+ while not(toplevelowner.symtabletype in [staticsymtable,globalsymtable]) do
+ toplevelowner:=toplevelowner.defowner.owner;
+ case obj.typ of
+ recorddef:
+ begin
+ { can't inherit from records }
+ AsmWrite('.class final ');
+ if toplevelowner.symtabletype=globalsymtable then
+ AsmWrite('public ');
+ AsmWriteln(obj.jvm_full_typename(true));
+ superclass:=java_fpcbaserecordtype;
+ end;
+ objectdef:
+ begin
+ case tobjectdef(obj).objecttype of
+ odt_javaclass:
+ begin
+ AsmWrite('.class ');
+ if oo_is_sealed in tobjectdef(obj).objectoptions then
+ AsmWrite('final ');
+ if (oo_is_abstract in tobjectdef(obj).objectoptions) or
+ (tobjectdef(obj).abstractcnt<>0) then
+ AsmWrite('abstract ');
+ if toplevelowner.symtabletype=globalsymtable then
+ AsmWrite('public ');
+ if (oo_is_enum_class in tobjectdef(obj).objectoptions) then
+ AsmWrite('enum ');
+ AsmWriteln(obj.jvm_full_typename(true));
+ superclass:=tobjectdef(obj).childof;
+ end;
+ odt_interfacejava:
+ begin
+ AsmWrite('.interface abstract ');
+ if toplevelowner.symtabletype=globalsymtable then
+ AsmWrite('public ');
+ AsmWriteLn(obj.jvm_full_typename(true));
+ { interfaces must always specify Java.lang.object as
+ superclass }
+ superclass:=java_jlobject;
+ end
+ else
+ internalerror(2011010906);
+ end;
+ end;
+ end;
+ { superclass }
+ if assigned(superclass) then
+ begin
+ AsmWrite('.super ');
+ if assigned(superclass.import_lib) then
+ AsmWrite(superclass.import_lib^+'/');
+ AsmWriteln(superclass.objextname^);
+ end;
+ { implemented interfaces }
+ if (obj.typ=objectdef) and
+ assigned(tobjectdef(obj).ImplementedInterfaces) then
+ begin
+ for i:=0 to tobjectdef(obj).ImplementedInterfaces.count-1 do
+ begin
+ intf:=TImplementedInterface(tobjectdef(obj).ImplementedInterfaces[i]).IntfDef;
+ AsmWrite('.implements ');
+ AsmWriteLn(intf.jvm_full_typename(true));
+ end;
+ end;
+ { signature for enum classes (must come after superclass and
+ implemented interfaces) }
+ if (obj.typ=objectdef) and
+ (oo_is_enum_class in tobjectdef(obj).objectoptions) then
+ AsmWriteln('.signature "Ljava/lang/Enum<L'+obj.jvm_full_typename(true)+';>;"');
+ { in case of nested class: relation to parent class }
+ if obj.owner.symtabletype in [objectsymtable,recordsymtable] then
+ AsmWriteln(InnerStructDef(obj));
+ { add all nested classes }
+ for i:=0 to obj.symtable.deflist.count-1 do
+ if (is_java_class_or_interface(tdef(obj.symtable.deflist[i])) or
+ (tdef(obj.symtable.deflist[i]).typ=recorddef)) and
+ not(df_generic in tdef(obj.symtable.deflist[i]).defoptions) then
+ AsmWriteln(InnerStructDef(tabstractrecorddef(obj.symtable.deflist[i])));
+ end;
+ AsmLn;
+ end;
+
+
+ procedure TJSAssembler.WriteInstruction(hp: tai);
+ begin
+ InstrWriter.WriteInstruction(hp);
+ end;
+
+
+ function TJSAssembler.MakeCmdLine: TCmdStr;
+ const
+ jasminjarname = 'jasmin.jar';
+ var
+ filenames: tcmdstr;
+ asmfile: tcmdstrlistitem;
+ jasminjarfound: boolean;
+ begin
+ if jasminjar='' then
+ begin
+ jasminjarfound:=false;
+ if utilsdirectory<>'' then
+ jasminjarfound:=FindFile(jasminjarname,utilsdirectory,false,jasminjar);
+ if not jasminjarfound then
+ jasminjarfound:=FindFileInExeLocations(jasminjarname,false,jasminjar);
+ if (not jasminjarfound) and not(cs_asm_extern in current_settings.globalswitches) then
+ begin
+ Message1(exec_e_assembler_not_found,jasminjarname);
+ current_settings.globalswitches:=current_settings.globalswitches+[cs_asm_extern];
+ end;
+ if jasminjarfound then
+ Message1(exec_t_using_assembler,jasminjar);
+ end;
+ result:=target_asm.asmcmd;
+ filenames:=ScriptFixFileName(AsmFileName);
+ if cs_asm_extern in current_settings.globalswitches then
+ filenames:=maybequoted(filenames);
+ asmfile:=tcmdstrlistitem(asmfiles.First);
+ while assigned(asmfile) do
+ begin
+ if cs_asm_extern in current_settings.globalswitches then
+ filenames:=filenames+' '+maybequoted(ScriptFixFileName(asmfile.str))
+ else
+ filenames:=filenames+' '+ScriptFixFileName(asmfile.str);
+ asmfile:=tcmdstrlistitem(asmfile.next);
+ end;
+ Replace(result,'$ASM',filenames);
+ if (path<>'') then
+ if cs_asm_extern in current_settings.globalswitches then
+ Replace(result,'$OBJDIR',maybequoted(ScriptFixFileName(path)))
+ else
+ Replace(result,'$OBJDIR',ScriptFixFileName(path))
+ else
+ Replace(result,'$OBJDIR','.');
+ if cs_asm_extern in current_settings.globalswitches then
+ Replace(result,'$JASMINJAR',maybequoted(ScriptFixFileName(jasminjar)))
+ else
+ Replace(result,'$JASMINJAR',ScriptFixFileName(jasminjar));
+ Replace(result,'$EXTRAOPT',asmextraopt);
+ end;
+
+
+ procedure TJSAssembler.NewAsmFileForStructDef(obj: tabstractrecorddef);
+ begin
+ if AsmSize<>AsmStartSize then
+ begin
+ AsmClose;
+ asmfiles.Concat(AsmFileName);
+ end
+ else
+ AsmClear;
+
+ AsmFileName:=obj.jvm_full_typename(false);
+ AsmFileName:=Path+FixFileName(AsmFileName)+target_info.asmext;
+ AsmCreate(cut_normal);
+ end;
+
+
+ function TJSAssembler.VisibilityToStr(vis: tvisibility): ansistring;
+ begin
+ case vis of
+ vis_hidden,
+ vis_strictprivate:
+ result:='private ';
+ { protected in Java means "accessible by subclasses *and* by classes
+ in the same package" -> similar to regular "protected" in Pascal;
+ "strict protected" is actually more strict in Pascal than in Java,
+ but there's not much we can do about that }
+ vis_protected,
+ vis_strictprotected:
+ result:='protected ';
+ vis_private:
+ { pick default visibility = "package" visibility; required because
+ other classes in the same unit can also access these symbols }
+ result:='';
+ vis_public:
+ result:='public '
+ else
+ internalerror(2010122609);
+ end;
+ end;
+
+
+ function TJSAssembler.MethodDefinition(pd: tprocdef): ansistring;
+ begin
+ //result:=VisibilityToStr(pd.visibility);
+ //if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or
+ // (po_classmethod in pd.procoptions) then
+ // result:=result+'static ';
+ //if (po_abstractmethod in pd.procoptions) or
+ // is_javainterface(tdef(pd.owner.defowner)) then
+ // result:=result+'abstract ';
+ //if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or
+ // (po_finalmethod in pd.procoptions) or
+ // (not(po_virtualmethod in pd.procoptions) and
+ // not(po_classmethod in pd.procoptions) and
+ // not(pd.proctypeoption in [potype_constructor,potype_class_constructor])) then
+ // result:=result+'final ';
+ //result:=result+pd.jvmmangledbasename(false);
+ end;
+
+
+ function TJSAssembler.ConstValue(csym: tconstsym): ansistring;
+ begin
+ case csym.consttyp of
+ constord:
+ { always interpret as signed value, because the JVM does not
+ support unsigned values }
+ case csym.constdef.size of
+ 1:result:=tostr(shortint(csym.value.valueord.svalue));
+ 2:result:=tostr(smallint(csym.value.valueord.svalue));
+ 4:result:=tostr(longint(csym.value.valueord.svalue));
+ 8:result:=tostr(csym.value.valueord.svalue);
+ end;
+ conststring:
+ result:=constastr(pchar(csym.value.valueptr),csym.value.len);
+ constreal:
+ case tfloatdef(csym.constdef).floattype of
+ s32real:
+ result:=constsingle(pbestreal(csym.value.valueptr)^);
+ s64real:
+ result:=constdouble(pbestreal(csym.value.valueptr)^);
+ else
+ internalerror(2011021204);
+ end;
+ constset:
+ result:='TODO: add support for constant sets';
+ constpointer:
+ { can only be null, but that's the default value and should not
+ be written; there's no primitive type that can hold nill }
+ internalerror(2011021201);
+ constnil:
+ internalerror(2011021202);
+ constresourcestring:
+ result:='TODO: add support for constant resource strings';
+ constwstring:
+ result:=constwstr(pcompilerwidestring(csym.value.valueptr)^.data,pcompilerwidestring(csym.value.valueptr)^.len);
+ constguid:
+ result:='TODO: add support for constant guids';
+ else
+ internalerror(2011021205);
+ end;
+ end;
+
+
+ function TJSAssembler.ConstAssignmentValue(csym: tconstsym): ansistring;
+ begin
+ result:='';
+ { nil is the default value -> don't write explicitly }
+ case csym.consttyp of
+ constpointer:
+ begin
+ if csym.value.valueordptr<>0 then
+ internalerror(2011021206);
+ end;
+ constnil:
+ ;
+ else
+ begin
+ { enums and sets are initialized as typed constants }
+ if not assigned(csym.constdef) or
+ not(csym.constdef.typ in [enumdef,setdef]) then
+ result:=' = '+ConstValue(csym);
+ end;
+ end;
+ end;
+
+
+ function TJSAssembler.ConstDefinition(sym: tconstsym): ansistring;
+ begin
+ //result:=VisibilityToStr(sym.visibility);
+ //{ formal constants are always class-level, not instance-level }
+ //result:=result+'static final ';
+ //if sp_internal in sym.symoptions then
+ // result:=result+'synthetic ';
+ //result:=result+jvmmangledbasename(sym,true);
+ //result:=result+ConstAssignmentValue(tconstsym(sym));
+ end;
+
+
+ function TJSAssembler.FieldDefinition(sym: tabstractvarsym): ansistring;
+ begin
+ //case sym.typ of
+ // staticvarsym:
+ // begin
+ // if sym.owner.symtabletype=globalsymtable then
+ // result:='public '
+ // else
+ // { package visbility }
+ // result:='';
+ // end;
+ // fieldvarsym,
+ // absolutevarsym:
+ // result:=VisibilityToStr(tstoredsym(sym).visibility);
+ // else
+ // internalerror(2011011204);
+ //end;
+ //if (sym.typ=staticvarsym) or
+ // (sp_static in sym.symoptions) then
+ // result:=result+'static ';
+ //if sym.varspez in [vs_const,vs_final] then
+ // result:=result+'final ';
+ //if sp_internal in sym.symoptions then
+ // result:=result+'synthetic ';
+ //{ mark the class fields of enum classes that contain the initialised
+ // enum instances as "enum" (recognise them by the fact that their type
+ // is the same as their parent class, and that this parent class is
+ // marked as oo_is_enum_class) }
+ //if assigned(sym.owner.defowner) and
+ // (tdef(sym.owner.defowner).typ=objectdef) and
+ // (oo_is_enum_class in tobjectdef(sym.owner.defowner).objectoptions) and
+ // (sym.typ=staticvarsym) and
+ // (tstaticvarsym(sym).vardef=tdef(sym.owner.defowner)) then
+ // result:=result+'enum ';
+ //result:=result+jvmmangledbasename(sym,true);
+ end;
+
+
+ function TJSAssembler.InnerStructDef(obj: tabstractrecorddef): ansistring;
+ var
+ extname: pshortstring;
+ kindname: ansistring;
+ begin
+ if not(obj.owner.defowner.typ in [objectdef,recorddef]) then
+ internalerror(2011021701);
+ { Nested classes in the Pascal sense are equivalent to "static"
+ inner classes in Java -- will be changed when support for
+ Java-style non-static classes is added }
+ case obj.typ of
+ recorddef:
+ begin
+ kindname:='class static ';
+ extname:=obj.symtable.realname;
+ end;
+ objectdef:
+ begin
+ extname:=tobjectdef(obj).objextname;
+ case tobjectdef(obj).objecttype of
+ odt_javaclass:
+ kindname:='class static ';
+ odt_interfacejava:
+ kindname:='interface static abstract ';
+ else
+ internalerror(2011021702);
+ end;
+ end;
+ else
+ internalerror(2011032809);
+ end;
+ result:=
+ '.inner '+
+ kindname+
+ VisibilityToStr(obj.typesym.visibility)+
+ extname^+
+ ' inner '+
+ obj.jvm_full_typename(true)+
+ ' outer '+
+ tabstractrecorddef(obj.owner.defowner).jvm_full_typename(true);
+ end;
+
+
+ procedure TJSAssembler.WriteProcDef(pd: tprocdef);
+ begin
+ //if not assigned(pd.exprasmlist) and
+ // not(po_abstractmethod in pd.procoptions) and
+ // (not is_javainterface(pd.struct) or
+ // (pd.proctypeoption in [potype_unitinit,potype_unitfinalize])) then
+ // exit;
+ //AsmWrite('.method ');
+ //AsmWriteln(MethodDefinition(pd));
+ //if jvmtypeneedssignature(pd) then
+ // begin
+ // AsmWrite('.signature "');
+ // AsmWrite(pd.jvmmangledbasename(true));
+ // AsmWriteln('"');
+ // end;
+ //WriteTree(pd.exprasmlist);
+ //AsmWriteln('.end method');
+ //AsmLn;
+ end;
+
+
+ procedure TJSAssembler.WriteFieldSym(sym: tabstractvarsym);
+ begin
+ { internal static field definition alias -> skip }
+ if (sym.owner.symtabletype in [recordsymtable,ObjectSymtable]) and
+ (sym.typ=staticvarsym) then
+ exit;
+ { external or threadvar definition -> no definition here }
+ if ([vo_is_external,vo_is_thread_var]*sym.varoptions)<>[] then
+ exit;
+ AsmWrite('.field ');
+ AsmWriteln(FieldDefinition(sym));
+ end;
+
+
+ procedure TJSAssembler.WriteConstSym(sym: tconstsym);
+ begin
+ AsmWrite('.field ');
+ AsmWriteln(ConstDefinition(sym));
+ end;
+
+
+ procedure TJSAssembler.WriteSymtableVarSyms(st: TSymtable);
+ var
+ sym : tsym;
+ i,j : longint;
+ begin
+ if not assigned(st) then
+ exit;
+ for i:=0 to st.SymList.Count-1 do
+ begin
+ sym:=tsym(st.SymList[i]);
+ case sym.typ of
+ staticvarsym,
+ fieldvarsym:
+ begin
+ WriteFieldSym(tabstractvarsym(sym));
+ if (sym.typ=staticvarsym) and
+ assigned(tstaticvarsym(sym).defaultconstsym) then
+ WriteFieldSym(tabstractvarsym(tstaticvarsym(sym).defaultconstsym));
+ end;
+ constsym:
+ begin
+ { multiple procedures can have constants with the same name }
+ if not assigned(sym.owner.defowner) or
+ (tdef(sym.owner.defowner).typ<>procdef) then
+ WriteConstSym(tconstsym(sym));
+ end;
+ procsym:
+ begin
+ for j:=0 to tprocsym(sym).procdeflist.count-1 do
+ if not(df_generic in tprocdef(tprocsym(sym).procdeflist[j]).defoptions) then
+ WriteSymtableVarSyms(tprocdef(tprocsym(sym).procdeflist[j]).localst);
+ end;
+ end;
+ end;
+ end;
+
+
+ procedure TJSAssembler.WriteSymtableProcdefs(st: TSymtable);
+ var
+ i : longint;
+ def : tdef;
+ begin
+ if not assigned(st) then
+ exit;
+ for i:=0 to st.DefList.Count-1 do
+ begin
+ def:=tdef(st.DefList[i]);
+ case def.typ of
+ procdef :
+ begin
+ { methods are also in the static/globalsymtable of the unit
+ -> make sure they are only written for the objectdefs that
+ own them }
+ if (not(st.symtabletype in [staticsymtable,globalsymtable]) or
+ (def.owner=st)) and
+ not(df_generic in def.defoptions) then
+ begin
+ WriteProcDef(tprocdef(def));
+ if assigned(tprocdef(def).localst) then
+ WriteSymtableProcdefs(tprocdef(def).localst);
+ end;
+ end;
+ end;
+ end;
+ end;
+
+ procedure TJSAssembler.WriteSymtableStructDefs(st: TSymtable);
+ var
+ i : longint;
+ def : tdef;
+ obj : tabstractrecorddef;
+ nestedstructs: tfpobjectlist;
+ begin
+ if not assigned(st) then
+ exit;
+ nestedstructs:=tfpobjectlist.create(false);
+ for i:=0 to st.DefList.Count-1 do
+ begin
+ def:=tdef(st.DefList[i]);
+ if df_generic in def.defoptions then
+ continue;
+ case def.typ of
+ objectdef:
+ if not(oo_is_external in tobjectdef(def).objectoptions) then
+ nestedstructs.add(def);
+ recorddef:
+ nestedstructs.add(def);
+ end;
+ end;
+ for i:=0 to nestedstructs.count-1 do
+ begin
+ obj:=tabstractrecorddef(nestedstructs[i]);
+ NewAsmFileForStructDef(obj);
+ WriteExtraHeader(obj);
+ WriteSymtableVarSyms(obj.symtable);
+ AsmLn;
+ WriteSymtableProcDefs(obj.symtable);
+ WriteSymtableStructDefs(obj.symtable);
+ end;
+ nestedstructs.free;
+ end;
+
+ constructor TJSAssembler.Create(smart: boolean);
+ begin
+ inherited create(smart);
+ InstrWriter:=TJSInstrWriter.Create(self);
+ asmfiles:=TCmdStrList.Create;
+ end;
+
+
+ procedure TJSAssembler.WriteAsmList;
+ begin
+{$ifdef EXTDEBUG}
+ if assigned(current_module.mainsource) then
+ Comment(V_Debug,'Start writing Jasmin-styled assembler output for '+current_module.mainsource);
+{$endif}
+
+ AsmStartSize:=AsmSize;
+ WriteExtraHeader(nil);
+(*
+ for hal:=low(TasmlistType) to high(TasmlistType) do
+ begin
+ AsmWriteLn(target_asm.comment+'Begin asmlist '+AsmlistTypeStr[hal]);
+ writetree(current_asmdata.asmlists[hal]);
+ AsmWriteLn(target_asm.comment+'End asmlist '+AsmlistTypeStr[hal]);
+ end;
+*)
+ { print all global variables }
+ WriteSymtableVarSyms(current_module.globalsymtable);
+ WriteSymtableVarSyms(current_module.localsymtable);
+ AsmLn;
+ { print all global procedures/functions }
+ WriteSymtableProcdefs(current_module.globalsymtable);
+ WriteSymtableProcdefs(current_module.localsymtable);
+
+ WriteSymtableStructDefs(current_module.globalsymtable);
+ WriteSymtableStructDefs(current_module.localsymtable);
+
+ AsmLn;
+{$ifdef EXTDEBUG}
+ if assigned(current_module.mainsource) then
+ Comment(V_Debug,'Done writing gas-styled assembler output for '+current_module.mainsource);
+{$endif EXTDEBUG}
+ end;
+
+
+ procedure TJSAssembler.RemoveAsm;
+ var
+ g : file;
+ begin
+ inherited;
+ if cs_asm_leave in current_settings.globalswitches then
+ exit;
+ while not asmfiles.empty do
+ begin
+ if cs_asm_extern in current_settings.globalswitches then
+ AsmRes.AddDeleteCommand(asmfiles.GetFirst)
+ else
+ begin
+ assign(g,asmfiles.GetFirst);
+ {$I-}
+ erase(g);
+ {$I+}
+ if ioresult<>0 then;
+ end;
+ end;
+ end;
+
+{****************************************************************************}
+{ JS Instruction Writer }
+{****************************************************************************}
+
+ constructor TJSInstrWriter.create(_owner: TJSAssembler);
+ begin
+ inherited create;
+ owner := _owner;
+ end;
+
+ function getreferencestring(var ref : treference) : ansistring;
+ begin
+ //if (ref.arrayreftype<>art_none) or
+ // (ref.index<>NR_NO) then
+ // internalerror(2010122809);
+ //if assigned(ref.symbol) then
+ // begin
+ // // global symbol or field -> full type and name
+ // // ref.base can be <> NR_NO in case an instance field is loaded.
+ // // This register is not part of this instruction, it will have
+ // // been placed on the stack by the previous one.
+ // if (ref.offset<>0) then
+ // internalerror(2010122811);
+ // result:=ref.symbol.name;
+ // end
+ //else
+ // begin
+ // // local symbol -> stack slot, stored in offset
+ // if ref.base<>NR_STACK_POINTER_REG then
+ // internalerror(2010122810);
+ // result:=tostr(ref.offset);
+ // end;
+ end;
+
+
+ function getopstr(const o:toper) : ansistring;
+ var
+ d: double;
+ s: single;
+ begin
+ case o.typ of
+ top_reg:
+ // should have been translated into a memory location by the
+ // register allocator)
+ if (cs_no_regalloc in current_settings.globalswitches) then
+ getopstr:=std_regname(o.reg)
+ else
+ internalerror(2010122803);
+ top_const:
+ str(o.val,result);
+ top_ref:
+ getopstr:=getreferencestring(o.ref^);
+ //top_single:
+ // begin
+ // result:=constsingle(o.sval);
+ // end;
+ //top_double:
+ // begin
+ // result:=constdouble(o.dval);
+ // end;
+ //top_string:
+ // begin
+ // result:=constastr(o.pcval,o.pcvallen);
+ // end;
+ //top_wstring:
+ // begin
+ // result:=constwstr(o.pwstrval^.data,getlengthwidestring(o.pwstrval));
+ // end
+ else
+ internalerror(2010122802);
+ end;
+ end;
+
+
+ procedure TJSInstrWriter.WriteInstruction(hp: tai);
+ var
+ s: ansistring;
+ i: byte;
+ sep: ansistring;
+ begin
+ //s:=#9+jas_op2str[taicpu(hp).opcode];
+ //if taicpu(hp).ops<>0 then
+ // begin
+ // sep:=#9;
+ // for i:=0 to taicpu(hp).ops-1 do
+ // begin
+ // s:=s+sep+getopstr(taicpu(hp).oper[i]^);
+ // sep:=' ';
+ // end;
+ // end;
+ //owner.AsmWriteLn(s);
+ end;
+
+{****************************************************************************}
+{ Jasmin Instruction Writer }
+{****************************************************************************}
+
+ const
+ as_js_asmjs_info : tasminfo =
+ (
+ id : as_js_asmjs;
+ idtxt : 'asm.js';
+ asmbin : '';
+ asmcmd : '';
+ supported_targets : [system_jvm_java32,system_jvm_android32];
+ flags : [];
+ labelprefix : 'L';
+ comment : ' ; ';
+ dollarsign : '$';
+ );
+
+
+begin
+ RegisterAssembler(as_js_asmjs_info,TJSAssembler);
+end.
diff --git a/compiler/fpcdefs.inc b/compiler/fpcdefs.inc
index 21c5c7284d..f104cddfe7 100644
--- a/compiler/fpcdefs.inc
+++ b/compiler/fpcdefs.inc
@@ -206,7 +206,6 @@
{$endif mips}
{$endif mipsel}
-
{$ifdef mips}
{$ifndef mips64}
{$define cpu32bit}
@@ -233,6 +232,14 @@
{$define SUPPORT_GET_FRAME}
{$endif}
+{$ifdef js}
+ {$define cpu32bit}
+ {$define cpu32bitalu}
+ {$define cpu32bitaddr}
+ {$define cpuhighleveltarget}
+ {$define symansistr}
+{$endif}
+
{$ifdef aarch64}
{$define cpu64bit}
{$define cpu64bitaddr}
diff --git a/compiler/globals.pas b/compiler/globals.pas
index ba08bcaf5d..6a60d0e248 100644
--- a/compiler/globals.pas
+++ b/compiler/globals.pas
@@ -473,6 +473,11 @@ interface
optimizecputype : cpu_none;
fputype : fpu_standard;
{$endif jvm}
+ {$ifdef js}
+ cputype : cpu_none;
+ optimizecputype : cpu_none;
+ fputype : fpu_standard;
+ {$endif js}
{$ifdef aarch64}
cputype : cpu_armv8;
optimizecputype : cpu_armv8;
diff --git a/compiler/js/aasmcpu.pas b/compiler/js/aasmcpu.pas
new file mode 100644
index 0000000000..034391ea89
--- /dev/null
+++ b/compiler/js/aasmcpu.pas
@@ -0,0 +1,304 @@
+{
+ Copyright (c) 1999-2002 by Mazen Neifer
+
+ Contains the assembler object for the JVM
+
+ 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];
+ 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;
+ internalerror(2014031401);
+ 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;
+ internalerror(2014031402);
+ 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;
+ internalerror(2014031403);
+ 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;
+ internalerror(2014031404);
+ 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;
+end.
diff --git a/compiler/js/cgcpu.pas b/compiler/js/cgcpu.pas
new file mode 100644
index 0000000000..893a924e36
--- /dev/null
+++ b/compiler/js/cgcpu.pas
@@ -0,0 +1,129 @@
+{
+ Copyright (c) 2010 by Jonas Maebe
+
+ This unit implements the code generator for JS
+
+ 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
+ TCgJS=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 TCgJS.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 TCgJS.done_register_allocators;
+ begin
+ rg[R_INTREGISTER].free;
+ rg[R_FPUREGISTER].free;
+ rg[R_MMREGISTER].free;
+ inherited done_register_allocators;
+ end;
+
+
+ function TCgJS.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 TCgJS.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 TCgJS.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 TCgJS.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:=TCgJS.Create;
+ end;
+
+end.
diff --git a/compiler/js/cpubase.pas b/compiler/js/cpubase.pas
new file mode 100644
index 0000000000..32294a4ba6
--- /dev/null
+++ b/compiler/js/cpubase.pas
@@ -0,0 +1,338 @@
+{
+ Copyright (c) 2010 by Jonas Maebe
+
+ Contains the base types for the Java VM
+
+ 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 rjsnor.inc}-1;
+ totherregisterset = set of tregisterindex;
+
+ const
+ { Available Superregisters }
+ {$i rjssup.inc}
+
+ { No Subregisters }
+ R_SUBWHOLE = R_SUBNONE;
+
+ { Available Registers }
+ {$i rjscon.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 = 10;
+
+ { Float Super register first and last }
+ first_fpu_imreg = 10;
+
+ { MM Super register first and last }
+ first_mm_imreg = 10;
+
+ regnumber_table : array[tregisterindex] of tregister = (
+ {$i rjsnum.inc}
+ );
+
+ EVALSTACKLOCS = [LOC_REGISTER,LOC_CREGISTER,LOC_FPUREGISTER,LOC_CFPUREGISTER,
+ LOC_MMREGISTER,LOC_CMMREGISTER,LOC_SUBSETREG,LOC_CSUBSETREG];
+
+{*****************************************************************************
+ 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 }
+
+ {# Registers which must be saved when calling a routine
+
+ }
+ saved_standard_registers : array[0..0] of tsuperregister = (
+ RS_NO
+ );
+
+ { this is only for the generic code which is not used for this architecture }
+ saved_address_registers : array[0..0] of tsuperregister = (RS_INVALID);
+ saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID);
+
+ { 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;
+
+implementation
+
+uses
+ rgbase;
+
+{*****************************************************************************
+ Helpers
+*****************************************************************************}
+
+ const
+ std_regname_table : array[tregisterindex] of string[15] = (
+ {$i rjsstd.inc}
+ );
+
+ regnumber_index : array[tregisterindex] of tregisterindex = (
+ {$i rjsrni.inc}
+ );
+
+ std_regname_index : array[tregisterindex] of tregisterindex = (
+ {$i rjssri.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;
+
+
+end.
diff --git a/compiler/js/cpuinfo.pas b/compiler/js/cpuinfo.pas
new file mode 100644
index 0000000000..d4927066c3
--- /dev/null
+++ b/compiler/js/cpuinfo.pas
@@ -0,0 +1,75 @@
+{
+ Copyright (c) 2010 by the Free Pascal development team
+
+ Basic Processor information for the Java VM
+
+ 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;
+
+Interface
+
+ uses
+ globtype;
+
+Type
+ bestreal = double;
+ ts32real = single;
+ ts64real = double;
+ ts80real = extended;
+ ts128real = extended;
+ ts64comp = comp;
+
+ pbestreal=^bestreal;
+
+ { possible supported processors for this target }
+ tcputype =
+ (cpu_none,
+ { JS for asm.js }
+ cpu_asmjs
+ );
+
+ tfputype =
+ (fpu_none,
+ fpu_standard
+ );
+
+
+Const
+ { calling conventions supported by the code generator }
+ supported_calling_conventions : tproccalloptions = [
+ pocall_internproc
+ ];
+
+ cputypestr : array[tcputype] of string[9] = ('',
+ 'ASMJS'
+ );
+
+ fputypestr : array[tfputype] of string[8] = (
+ 'NONE',
+ 'STANDARD'
+ );
+
+ { Supported optimizations, only used for information }
+ supported_optimizerswitches = genericlevel1optimizerswitches+
+ genericlevel2optimizerswitches+
+ genericlevel3optimizerswitches-
+ { no need to write info about those }
+ [cs_opt_level1,cs_opt_level2,cs_opt_level3]+
+ [cs_opt_loopunroll,cs_opt_nodecse];
+
+ level1optimizerswitches = genericlevel1optimizerswitches;
+ level2optimizerswitches = genericlevel2optimizerswitches + level1optimizerswitches + [cs_opt_nodecse];
+ level3optimizerswitches = genericlevel3optimizerswitches + level2optimizerswitches + [{,cs_opt_loopunroll}];
+ level4optimizerswitches = genericlevel4optimizerswitches + level3optimizerswitches + [];
+
+Implementation
+
+end.
diff --git a/compiler/js/cpunode.pas b/compiler/js/cpunode.pas
new file mode 100644
index 0000000000..515ec81e8c
--- /dev/null
+++ b/compiler/js/cpunode.pas
@@ -0,0 +1,38 @@
+{******************************************************************************
+ Copyright (c) 2000-2010 by Florian Klaempfl and Jonas Maebe
+
+ Includes the JS 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,
+ { these are not really nodes }
+ rgcpu,tgcpu;
+
+end.
diff --git a/compiler/js/cpupara.pas b/compiler/js/cpupara.pas
new file mode 100644
index 0000000000..fb2d330e1a
--- /dev/null
+++ b/compiler/js/cpupara.pas
@@ -0,0 +1,306 @@
+{
+ Copyright (c) 1998-2010 by Florian Klaempfl, Jonas Maebe
+
+ Calling conventions for the JVM
+
+ 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
+
+ { TJSParaManager }
+
+ TJSParaManager=class(TParaManager)
+ 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(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; 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,
+ aasmcpu,
+ hlcgobj;
+
+
+ procedure TJSParaManager.GetIntParaLoc(pd : tabstractprocdef; nr : longint; var cgpara : tcgpara);
+ begin
+ { not yet implemented/used }
+ internalerror(2010121001);
+ end;
+
+ function TJSParaManager.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 TJSParaManager.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 TJSParaManager.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]));
+ end;
+
+
+ function TJSParaManager.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) };
+ end;
+
+
+ function TJSParaManager.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 TJSParaManager.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
+{!!!! else if jvmimplicitpointertype(result.def) then
+ begin
+ retcgsize:=OS_ADDR;
+ result.def:=getpointerdef(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 TJSParaManager.param_use_paraloc(const cgpara: tcgpara): boolean;
+ begin
+ { all parameters are copied by the VM to local variable locations }
+ result:=true;
+ end;
+
+ function TJSParaManager.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 TJSParaManager.is_stack_paraloc(paraloc: pcgparalocation): boolean;
+ begin
+ { all parameters are passed on the evaluation stack }
+ result:=true;
+ end;
+
+
+ function TJSParaManager.create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;
+ var
+ parasize : longint;
+ begin
+ parasize:=0;
+ { calculate the registers for the normal parameters }
+ create_paraloc_info_intern(p,callerside,p.paras,parasize);
+ { append the varargs }
+ create_paraloc_info_intern(p,callerside,varargspara,parasize);
+ result:=parasize;
+ end;
+
+
+ procedure TJSParaManager.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
+{!!!! else if jvmimplicitpointertype(hp.vardef) then
+ begin
+ paracgsize:=OS_ADDR;
+ paradef:=getpointerdef(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;
+ 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 TJSParaManager.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:=TJSParaManager.create;
+end.
diff --git a/compiler/js/cpupi.pas b/compiler/js/cpupi.pas
new file mode 100644
index 0000000000..5bb4c7b8a0
--- /dev/null
+++ b/compiler/js/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
+
+ { TSparcProcInfo }
+
+ TJSProcInfo=class(tcgprocinfo)
+ public
+ procedure set_first_temp_offset;override;
+ end;
+
+implementation
+
+ uses
+ systems,globals,
+ tgobj,paramgr,symconst;
+
+ procedure TJSProcInfo.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:=TJSProcInfo;
+end.
diff --git a/compiler/js/cputarg.pas b/compiler/js/cputarg.pas
new file mode 100644
index 0000000000..186ff8cf3c
--- /dev/null
+++ b/compiler/js/cputarg.pas
@@ -0,0 +1,58 @@
+{
+ Copyright (c) 2001-2010 by Peter Vreman and Jonas Maebe
+
+ Includes the JS 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
+**************************************}
+ ,t_jvm
+
+{**************************************
+ Assemblers
+**************************************}
+ ,agjs
+
+{**************************************
+ Assembler Readers
+**************************************}
+
+{**************************************
+ Debuginfo
+**************************************}
+ //,dbgjasm
+ ;
+
+end.
diff --git a/compiler/js/hlcgcpu.pas b/compiler/js/hlcgcpu.pas
new file mode 100644
index 0000000000..9e55cb6f35
--- /dev/null
+++ b/compiler/js/hlcgcpu.pas
@@ -0,0 +1,64 @@
+{
+ Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+ Member of the Free Pascal development team
+
+ This unit implements the js 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,
+ cpubase, hlcgobj, cgbase, cgutils, parabase;
+
+ type
+ thlcgjs = class(thlcgobj)
+ public
+ constructor create;
+ end;
+
+ procedure create_hlcodegen;
+
+implementation
+
+ uses
+ verbose,cutils,globals,fmodule,constexp,
+ defutil,
+ aasmtai,aasmcpu,
+ symtable,
+ procinfo,cpuinfo,cgcpu,tgobj;
+
+
+ constructor thlcgjs.create;
+ begin
+ end;
+
+
+ procedure create_hlcodegen;
+ begin
+ hlcg:=thlcgjs.create;
+ create_codegen;
+ end;
+
+end.
diff --git a/compiler/js/rgcpu.pas b/compiler/js/rgcpu.pas
new file mode 100644
index 0000000000..879a752bc1
--- /dev/null
+++ b/compiler/js/rgcpu.pas
@@ -0,0 +1,358 @@
+{
+ Copyright (c) 2010 by Jonas Maebe
+
+ This unit implements the JVM 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;
+ 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]);
+ load:=nextskipping(dealloc,[ait_comment]);
+ 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;
+
+
+ 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]);
+ 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) then
+ begin
+ removedsomething:=true;
+ continue;
+ end;
+ { todo in peephole optimizer:
+ alloc regx // not double precision
+ store regx // not double precision
+ load regy or memy
+ dealloc regx
+ load regx
+ -> change into
+ load regy or memy
+ swap // can only handle single precision
+
+ and then
+ swap
+ <commutative op>
+ -> remove swap
+ }
+ end;
+ 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;
+ 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);
+ end;
+ p:=Tai(p.next);
+ end;
+ freemem(spill_temps[R_INTREGISTER]);
+ freemem(spill_temps[R_FPUREGISTER]);
+ templist.free;
+ end;
+
+end.
diff --git a/compiler/js/rjscon.inc b/compiler/js/rjscon.inc
new file mode 100644
index 0000000000..913141e2e5
--- /dev/null
+++ b/compiler/js/rjscon.inc
@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from jsreg.dat }
+NR_NO = tregister($00000000);
+NR_R0 = tregister($01000000);
+NR_R1 = tregister($01000001);
+NR_R2 = tregister($01000002);
diff --git a/compiler/js/rjsnor.inc b/compiler/js/rjsnor.inc
new file mode 100644
index 0000000000..9fb50d2944
--- /dev/null
+++ b/compiler/js/rjsnor.inc
@@ -0,0 +1,2 @@
+{ don't edit, this file is generated from jsreg.dat }
+4
diff --git a/compiler/js/rjsnum.inc b/compiler/js/rjsnum.inc
new file mode 100644
index 0000000000..1721d28fdf
--- /dev/null
+++ b/compiler/js/rjsnum.inc
@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from jsreg.dat }
+tregister($00000000),
+tregister($01000000),
+tregister($01000001),
+tregister($01000002)
diff --git a/compiler/js/rjsrni.inc b/compiler/js/rjsrni.inc
new file mode 100644
index 0000000000..81cdaeaae1
--- /dev/null
+++ b/compiler/js/rjsrni.inc
@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from jsreg.dat }
+0,
+1,
+2,
+3
diff --git a/compiler/js/rjssri.inc b/compiler/js/rjssri.inc
new file mode 100644
index 0000000000..bcd835f76a
--- /dev/null
+++ b/compiler/js/rjssri.inc
@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from jsreg.dat }
+0,
+3,
+1,
+2
diff --git a/compiler/js/rjsstd.inc b/compiler/js/rjsstd.inc
new file mode 100644
index 0000000000..3f7acf5779
--- /dev/null
+++ b/compiler/js/rjsstd.inc
@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from jsreg.dat }
+'INVALID',
+'evalstacktopptr',
+'localsstackptr',
+'evalstacktop'
diff --git a/compiler/js/rjssup.inc b/compiler/js/rjssup.inc
new file mode 100644
index 0000000000..3640d74e8b
--- /dev/null
+++ b/compiler/js/rjssup.inc
@@ -0,0 +1,5 @@
+{ don't edit, this file is generated from jsreg.dat }
+RS_NO = $00;
+RS_R0 = $00;
+RS_R1 = $01;
+RS_R2 = $02;
diff --git a/compiler/js/symcpu.pas b/compiler/js/symcpu.pas
new file mode 100644
index 0000000000..23a03112de
--- /dev/null
+++ b/compiler/js/symcpu.pas
@@ -0,0 +1,211 @@
+{
+ Copyright (c) 2014 by the FPC development team and Florian Klaempfl
+
+ Symbol table overrides for JS
+
+ 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
+ symtype,symdef,symsym,globtype;
+
+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)
+ end;
+ tcpuprocvardefclass = class of tcpuprocvardef;
+
+ tcpuprocdef = class(tprocdef)
+ end;
+ tcpuprocdefclass = class of tcpuprocdef;
+
+ tcpustringdef = class(tstringdef)
+ end;
+ tcpustringdefclass = class of tcpustringdef;
+
+ tcpuenumdef = class(tenumdef)
+ 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;
+
+ tcpunamespacesym = class(tnamespacesym)
+ end;
+ tcpunamespacesymclass = class of tcpunamespacesym;
+
+ tcpuprocsym = class(tprocsym)
+ end;
+ tcpuprocsymclass = class of tcpuprocsym;
+
+ tcpuypesym = class(ttypesym)
+ end;
+ tcpuypesymclass = class of tcpuypesym;
+
+ tcpufieldvarsym = class(tfieldvarsym)
+ end;
+ tcpufieldvarsymclass = class of tcpufieldvarsym;
+
+ tcpulocalvarsym = class(tlocalvarsym)
+ end;
+ tcpulocalvarsymclass = class of tcpulocalvarsym;
+
+ tcpuparavarsym = class(tparavarsym)
+ end;
+ tcpuparavarsymclass = class of tcpuparavarsym;
+
+ tcpustaticvarsym = class(tstaticvarsym)
+ end;
+ tcpustaticvarsymclass = class of tcpustaticvarsym;
+
+ tcpuabsolutevarsym = class(tabsolutevarsym)
+ end;
+ tcpuabsolutevarsymclass = class of tcpuabsolutevarsym;
+
+ tcpupropertysym = class(tpropertysym)
+ 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
+
+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;
+ cnamespacesym:=tcpunamespacesym;
+ cprocsym:=tcpuprocsym;
+ ctypesym:=tcpuypesym;
+ cfieldvarsym:=tcpufieldvarsym;
+ clocalvarsym:=tcpulocalvarsym;
+ cparavarsym:=tcpuparavarsym;
+ cstaticvarsym:=tcpustaticvarsym;
+ cabsolutevarsym:=tcpuabsolutevarsym;
+ cpropertysym:=tcpupropertysym;
+ cconstsym:=tcpuconstsym;
+ cenumsym:=tcpuenumsym;
+ csyssym:=tcpusyssym;
+end.
+
diff --git a/compiler/js/tgcpu.pas b/compiler/js/tgcpu.pas
new file mode 100644
index 0000000000..b34384f90b
--- /dev/null
+++ b/compiler/js/tgcpu.pas
@@ -0,0 +1,261 @@
+{
+ Copyright (C) 2010 by Jonas Maebe
+
+ This unit handles the temporary variables for the JVM
+
+ 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 handles the temporary variables for the JVM.
+}
+unit tgcpu;
+
+{$i fpcdefs.inc}
+
+ interface
+
+ uses
+ globtype,
+ aasmdata,
+ cgutils,
+ symtype,tgobj;
+
+ type
+ ttgjs = class(ttgobj)
+ protected
+ procedure getimplicitobjtemp(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference);
+ function getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
+ procedure alloctemp(list: TAsmList; size, alignment: longint; temptype: ttemptype; def: tdef; out ref: treference); override;
+ public
+ procedure setfirsttemp(l : longint); override;
+ procedure getlocal(list: TAsmList; size: longint; alignment: shortint; def: tdef; var ref: treference); override;
+ procedure gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference); override;
+ procedure gethltemptyped(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference); override;
+ end;
+
+ implementation
+
+ uses
+ verbose,
+ cgbase,
+ symconst,symdef,symsym,defutil,
+ cpubase,aasmcpu,
+ hlcgobj,hlcgcpu;
+
+
+ procedure ttgjs.getimplicitobjtemp(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference);
+ var
+ sym: tsym;
+ pd: tprocdef;
+ begin
+ gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+ list.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(tabstractrecorddef(def).jvm_full_typename(true))));
+ { the constructor doesn't return anything, so put a duplicate of the
+ self pointer on the evaluation stack for use as function result
+ after the constructor has run }
+ list.concat(taicpu.op_none(a_dup));
+
+ //!!!!!!!!!!!! thlcgjvm(hlcg).incstack(list,2);
+
+ { call the constructor }
+ sym:=tsym(tabstractrecorddef(def).symtable.find('CREATE'));
+ if assigned(sym) and
+ (sym.typ=procsym) then
+ begin
+ pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
+ if not assigned(pd) then
+ internalerror(2011032701);
+ end
+ else
+ internalerror(2011060301);
+ hlcg.a_call_name(list,pd,pd.mangledname,nil,false);
+
+ //!!!!!!!!!!!!!! thlcgjvm(hlcg).decstack(list,1);
+
+ { store reference to instance }
+ //!!!!!!!!!!!!!!! thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+ end;
+
+
+ function ttgjs.getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
+ var
+ eledef: tdef;
+ ndim: longint;
+ sym: tsym;
+ pd: tprocdef;
+ begin
+ result:=false;
+ case def.typ of
+ arraydef:
+ begin
+ if not is_dynamic_array(def) then
+ begin
+ { allocate an array of the right size }
+ gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+ ndim:=0;
+ eledef:=def;
+ repeat
+ //!!!!!!!!!!!!!!!! if forcesize<>-1 then
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).a_load_const_stack(list,s32inttype,forcesize div tarraydef(eledef).elesize,R_INTREGISTER)
+ //!!!!!!!!!!!!!!!! else
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).a_load_const_stack(list,s32inttype,tarraydef(eledef).elecount,R_INTREGISTER);
+ eledef:=tarraydef(eledef).elementdef;
+ inc(ndim);
+ forcesize:=-1;
+ until (eledef.typ<>arraydef) or
+ is_dynamic_array(eledef);
+ eledef:=tarraydef(def).elementdef;
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).g_newarray(list,def,ndim);
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+ result:=true;
+ end;
+ end;
+ recorddef:
+ begin
+ getimplicitobjtemp(list,def,temptype,ref);
+ result:=true;
+ end;
+ setdef:
+ begin
+ if tsetdef(def).elementdef.typ=enumdef then
+ begin
+ { load enum class type }
+ //!!!!!!!!!!!!!!!! list.concat(taicpu.op_sym(a_ldc,current_asmdata.RefAsmSymbol(tenumdef(tsetdef(def).elementdef).getbasedef.classdef.jvm_full_typename(true))));
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+ { call tenumset.noneOf() class method }
+ sym:=tsym(tobjectdef(java_juenumset).symtable.find('NONEOF'));
+ if assigned(sym) and
+ (sym.typ=procsym) then
+ begin
+ if tprocsym(sym).procdeflist.Count<>1 then
+ internalerror(2011062801);
+ pd:=tprocdef(tprocsym(sym).procdeflist[0]);
+ end;
+ hlcg.a_call_name(list,pd,pd.mangledname,nil,false);
+ { static calls method replaces parameter with set instance
+ -> no change in stack height }
+ end
+ else
+ begin
+ list.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(java_jubitset.jvm_full_typename(true))));
+ { the constructor doesn't return anything, so put a duplicate of the
+ self pointer on the evaluation stack for use as function result
+ after the constructor has run }
+ list.concat(taicpu.op_none(a_dup));
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).incstack(list,2);
+ { call the constructor }
+ sym:=tsym(java_jubitset.symtable.find('CREATE'));
+ if assigned(sym) and
+ (sym.typ=procsym) then
+ begin
+ pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
+ if not assigned(pd) then
+ internalerror(2011062802);
+ end
+ else
+ internalerror(2011062803);
+ hlcg.a_call_name(list,pd,pd.mangledname,nil,false);
+ { duplicate self pointer is removed }
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).decstack(list,1);
+ end;
+ { store reference to instance }
+ gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+ result:=true;
+ end;
+ procvardef:
+ begin
+ if not tprocvardef(def).is_addressonly then
+ begin
+ //!!!!!!!!!!!!!!!! getimplicitobjtemp(list,tprocvardef(def).classdef,temptype,ref);
+ result:=true;
+ end;
+ end;
+ stringdef:
+ begin
+ if is_shortstring(def) then
+ begin
+ gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+ { add the maxlen parameter (s8inttype because parameters must
+ be sign extended) }
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).a_load_const_stack(list,s8inttype,shortint(tstringdef(def).len),R_INTREGISTER);
+ { call the constructor }
+ sym:=tsym(tobjectdef(java_shortstring).symtable.find('CREATEEMPTY'));
+ if assigned(sym) and
+ (sym.typ=procsym) then
+ begin
+ if tprocsym(sym).procdeflist.Count<>1 then
+ internalerror(2011052404);
+ pd:=tprocdef(tprocsym(sym).procdeflist[0]);
+ end;
+ hlcg.a_call_name(list,pd,pd.mangledname,nil,false);
+ { static calls method replaces parameter with string instance
+ -> no change in stack height }
+ { store reference to instance }
+ //!!!!!!!!!!!!!!!! thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+ result:=true;
+ end;
+ end;
+ end;
+ end;
+
+
+ procedure ttgjs.alloctemp(list: TAsmList; size, alignment: longint; temptype: ttemptype; def: tdef; out ref: treference);
+ begin
+ { the JVM only supports 1 slot (= 4 bytes in FPC) and 2 slot (= 8 bytes in
+ FPC) temps on the stack. double and int64 are 2 slots, the rest is one slot.
+ There are no problems with reusing the same slot for a value of a different
+ type. There are no alignment requirements either. }
+ if size<4 then
+ size:=4;
+ if not(size in [4,8]) then
+ internalerror(2010121401);
+ { don't pass on "def", since we don't care if a slot is used again for a
+ different type }
+ inherited alloctemp(list, size shr 2, 1, temptype, nil,ref);
+ end;
+
+
+ procedure ttgjs.setfirsttemp(l: longint);
+ begin
+ firsttemp:=l;
+ lasttemp:=l;
+ end;
+
+
+ procedure ttgjs.getlocal(list: TAsmList; size: longint; alignment: shortint; def: tdef; var ref: treference);
+ begin
+ if not getifspecialtemp(list,def,size,tt_persistent,ref) then
+ inherited;
+ end;
+
+
+ procedure ttgjs.gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference);
+ begin
+ if not getifspecialtemp(list,def,forcesize,temptype,ref) then
+ inherited;
+ end;
+
+ procedure ttgjs.gethltemptyped(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference);
+ begin
+ gethltemp(list,def,def.size,temptype,ref);
+ end;
+
+
+begin
+ tgobjclass:=ttgjs;
+end.
diff --git a/compiler/pp.pas b/compiler/pp.pas
index 09c307b7b4..acb773bc98 100644
--- a/compiler/pp.pas
+++ b/compiler/pp.pas
@@ -153,6 +153,12 @@ program pp;
{$endif CPUDEFINED}
{$define CPUDEFINED}
{$endif AARCH64}
+{$ifdef JS}
+ {$ifdef CPUDEFINED}
+ {$fatal ONLY one of the switches for the CPU type must be defined}
+ {$endif CPUDEFINED}
+ {$define CPUDEFINED}
+{$endif}
{$ifndef CPUDEFINED}
{$fatal A CPU type switch must be defined}
{$endif CPUDEFINED}
diff --git a/compiler/ppcjs.lpi b/compiler/ppcjs.lpi
new file mode 100644
index 0000000000..f718e17320
--- /dev/null
+++ b/compiler/ppcjs.lpi
@@ -0,0 +1,74 @@
+<?xml version="1.0"?>
+<CONFIG>
+ <ProjectOptions>
+ <Version Value="9"/>
+ <PathDelim Value="\"/>
+ <General>
+ <Flags>
+ <MainUnitHasUsesSectionForAllUnits Value="False"/>
+ <MainUnitHasCreateFormStatements Value="False"/>
+ <MainUnitHasTitleStatement Value="False"/>
+ <LRSInOutputDirectory Value="False"/>
+ </Flags>
+ <SessionStorage Value="InProjectDir"/>
+ <MainUnit Value="0"/>
+ <Title Value="ppcjs"/>
+ </General>
+ <BuildModes Count="1">
+ <Item1 Name="default" Default="True"/>
+ </BuildModes>
+ <PublishOptions>
+ <Version Value="2"/>
+ <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+ <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+ </PublishOptions>
+ <RunParams>
+ <local>
+ <FormatVersion Value="1"/>
+ </local>
+ </RunParams>
+ <Units Count="1">
+ <Unit0>
+ <Filename Value="pp.pas"/>
+ <IsPartOfProject Value="True"/>
+ <UnitName Value="pp"/>
+ </Unit0>
+ </Units>
+ </ProjectOptions>
+ <CompilerOptions>
+ <Version Value="11"/>
+ <PathDelim Value="\"/>
+ <Target>
+ <Filename Value="js\pp"/>
+ </Target>
+ <SearchPaths>
+ <IncludeFiles Value="js"/>
+ <OtherUnitFiles Value="js;systems"/>
+ <UnitOutputDirectory Value="js\lazbuild"/>
+ </SearchPaths>
+ <Parsing>
+ <SyntaxOptions>
+ <CStyleOperator Value="False"/>
+ <AllowLabel Value="False"/>
+ <CPPInline Value="False"/>
+ <UseAnsiStrings Value="False"/>
+ </SyntaxOptions>
+ </Parsing>
+ <Other>
+ <Verbosity>
+ <ShowWarn Value="False"/>
+ <ShowNotes Value="False"/>
+ <ShowHints Value="False"/>
+ </Verbosity>
+ <ConfigFile>
+ <StopAfterErrCount Value="50"/>
+ </ConfigFile>
+ <CompilerMessages>
+ <UseMsgFile Value="True"/>
+ </CompilerMessages>
+ <CustomOptions Value="-djs
+-dnoopt"/>
+ <CompilerPath Value="$(CompPath)"/>
+ </Other>
+ </CompilerOptions>
+</CONFIG>
diff --git a/compiler/systems.inc b/compiler/systems.inc
index 13181c2a41..cdd3ed92ca 100644
--- a/compiler/systems.inc
+++ b/compiler/systems.inc
@@ -207,6 +207,7 @@
,as_x86_64_nasmdarwin
,as_i8086_nasm
,as_i8086_nasmobj
+ ,as_js_asmjs
);
tlink = (ld_none,
diff --git a/compiler/utils/mkjsreg.pp b/compiler/utils/mkjsreg.pp
new file mode 100644
index 0000000000..30980d9526
--- /dev/null
+++ b/compiler/utils/mkjsreg.pp
@@ -0,0 +1,265 @@
+{
+ Copyright (c) 1998-2002 by Peter Vreman and Florian Klaempfl
+
+ Convert jsreg.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 jsreg.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,'jsreg.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,'rjscon.inc');
+ openinc(supfile,'rjssup.inc');
+ openinc(numfile,'rjsnum.inc');
+ openinc(stdfile,'rjsstd.inc');
+ openinc(norfile,'rjsnor.inc');
+ openinc(rnifile,'rjsrni.inc');
+ openinc(srifile,'rjssri.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.