diff options
author | florian <florian@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2014-04-06 12:49:38 +0000 |
---|---|---|
committer | florian <florian@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2014-04-06 12:49:38 +0000 |
commit | c31849d95470a761adb8c76f563baf26e6ae7bcd (patch) | |
tree | 250428351814b3b897beddd084fac97b79f316c3 | |
parent | 87496a06da21831d719eabd81808523542f1d809 (diff) | |
download | fpc-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.pas | 1233 | ||||
-rw-r--r-- | compiler/fpcdefs.inc | 9 | ||||
-rw-r--r-- | compiler/globals.pas | 5 | ||||
-rw-r--r-- | compiler/js/aasmcpu.pas | 304 | ||||
-rw-r--r-- | compiler/js/cgcpu.pas | 129 | ||||
-rw-r--r-- | compiler/js/cpubase.pas | 338 | ||||
-rw-r--r-- | compiler/js/cpuinfo.pas | 75 | ||||
-rw-r--r-- | compiler/js/cpunode.pas | 38 | ||||
-rw-r--r-- | compiler/js/cpupara.pas | 306 | ||||
-rw-r--r-- | compiler/js/cpupi.pas | 65 | ||||
-rw-r--r-- | compiler/js/cputarg.pas | 58 | ||||
-rw-r--r-- | compiler/js/hlcgcpu.pas | 64 | ||||
-rw-r--r-- | compiler/js/rgcpu.pas | 358 | ||||
-rw-r--r-- | compiler/js/rjscon.inc | 5 | ||||
-rw-r--r-- | compiler/js/rjsnor.inc | 2 | ||||
-rw-r--r-- | compiler/js/rjsnum.inc | 5 | ||||
-rw-r--r-- | compiler/js/rjsrni.inc | 5 | ||||
-rw-r--r-- | compiler/js/rjssri.inc | 5 | ||||
-rw-r--r-- | compiler/js/rjsstd.inc | 5 | ||||
-rw-r--r-- | compiler/js/rjssup.inc | 5 | ||||
-rw-r--r-- | compiler/js/symcpu.pas | 211 | ||||
-rw-r--r-- | compiler/js/tgcpu.pas | 261 | ||||
-rw-r--r-- | compiler/pp.pas | 6 | ||||
-rw-r--r-- | compiler/ppcjs.lpi | 74 | ||||
-rw-r--r-- | compiler/systems.inc | 1 | ||||
-rw-r--r-- | compiler/utils/mkjsreg.pp | 265 |
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. |