Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
1237 lines (1117 sloc) 41.5 KB
{
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 Jasmin assembler (JVM bytecode) output.
}
unit agjasmin;
{$i fpcdefs.inc}
interface
uses
cclasses,
globtype,globals,
symconst,symbase,symdef,symsym,
aasmbase,aasmtai,aasmdata,aasmcpu,
assemble;
type
TJasminInstrWriter = class;
{# This is a derived class which is used to write
Jasmin-styled assembler.
}
{ TJasminAssembler }
TJasminAssembler=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: TJasminInstrWriter;
end;
{# This is the base class for writing instructions.
The WriteInstruction() method must be overridden
to write a single instruction to the assembler
file.
}
{ TJasminInstrWriter }
TJasminInstrWriter = class
constructor create(_owner: TJasminAssembler);
procedure WriteInstruction(hp : tai); virtual;
protected
owner: TJasminAssembler;
end;
implementation
uses
SysUtils,
cutils,cfileutl,systems,script,
fmodule,finput,verbose,
symtype,symtable,jvmdef,
itcpujas,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 TJasminAssembler.Destroy;
begin
InstrWriter.free;
asmfiles.free;
inherited destroy;
end;
procedure TJasminAssembler.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 TJasminAssembler.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 TJasminAssembler.WriteInstruction(hp: tai);
begin
InstrWriter.WriteInstruction(hp);
end;
function TJasminAssembler.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))
end;
procedure TJasminAssembler.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 TJasminAssembler.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 TJasminAssembler.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 TJasminAssembler.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 TJasminAssembler.ConstAssignmentValue(csym: tconstsym): ansistring;
begin
{ nil is the default value -> don't write explicitly }
case csym.consttyp of
constpointer:
begin
if csym.value.valueordptr<>0 then
internalerror(2011021206);
result:='';
end;
constnil:
result:='';
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 TJasminAssembler.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 TJasminAssembler.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 TJasminAssembler.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 ';
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 TJasminAssembler.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 TJasminAssembler.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 TJasminAssembler.WriteConstSym(sym: tconstsym);
begin
AsmWrite('.field ');
AsmWriteln(ConstDefinition(sym));
end;
procedure TJasminAssembler.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 TJasminAssembler.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 TJasminAssembler.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 TJasminAssembler.Create(smart: boolean);
begin
inherited create(smart);
InstrWriter:=TJasminInstrWriter.Create(self);
asmfiles:=TCmdStrList.Create;
end;
procedure TJasminAssembler.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 TJasminAssembler.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;
{****************************************************************************}
{ Jasmin Instruction Writer }
{****************************************************************************}
constructor TJasminInstrWriter.create(_owner: TJasminAssembler);
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 TJasminInstrWriter.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_jvm_jasmin_info : tasminfo =
(
id : as_jvm_jasmin;
idtxt : 'Jasmin';
asmbin : 'java';
asmcmd : '-jar $JASMINJAR $ASM -d $OBJDIR';
supported_targets : [system_jvm_java32,system_jvm_android32];
flags : [];
labelprefix : 'L';
comment : ' ; ';
);
begin
RegisterAssembler(as_jvm_jasmin_info,TJasminAssembler);
end.
Something went wrong with that request. Please try again.