paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-01 19:33:42 +02:00
Code Issues Packages Projects Releases Wiki Activity
43c5ed20c2
fpc/compiler/agjasmin.pas
Jonas Maebe 43c5ed20c2 + support for initialising typed constants via compiler-generated 
assignment-nodes. For global typed constants and typed constants/
    local variable initialisers in regular functions/procedurs, the
    assignments are performed in the unit initialisation code. For
    those in object/record definitions and their methods, it's done
    in the class constructor. Since we may not yet have parsed all
    method implementations when the class constructor is parsed, part
    of these may be initialised in a helper routine called from the
    class constructor. The ones known when the class constructor is
    parsed are inited there, because the ones marked as "final" and
    declared as static class fields must be initialised in the class
    constructor for Java
   o new set systems_typed_constants_node_init in systems unit that
     indicates that a target uses node trees to initialise typed consts
     instead of an initialised data section
   o mark typed constants in {$j-} mode as "final" for JVM
   o mangle the name of staticvarsyms inside localtables a bit to avoid
     name clashes (only with procedure names for now, no parameters yet
     so can still cause problems with overloaded routines)
   o after a routine has been parsed, it is now processed by
     cnodeutils.wrap_proc_body(), which can add extra nodes before code
     generation (used for injected the typed constant node trees)

git-svn-id: branches/jvmbackend@18475 -
2011-08-20 08:02:58 +00:00

1156 lines
38 KiB
ObjectPascal
Raw Blame History

{
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): string;
function MethodDefinition(pd: tprocdef): string;
function ConstValue(csym: tconstsym): ansistring;
function ConstAssignmentValue(csym: tconstsym): ansistring;
function ConstDefinition(sym: tconstsym): string;
function FieldDefinition(sym: tabstractvarsym): string;
function InnerStructDef(obj: tabstractrecorddef): string;
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;
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
// since Jasmin expects an UTF-16 string, we can't safely
// have high ASCII characters since they'll be
// re-interpreted as utf-16 anyway
internalerror(2010122808);
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): string;
begin
result:='0fx'+hexstr(longint(t32bitarray(s)),8);
end;
function constdouble(d: double): string;
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 : string;
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 assigned(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: string;
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 assigned(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
AsmWrite('.class ');
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 toplevelowner.symtabletype=globalsymtable then
AsmWrite('public ');
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 ');
if assigned(intf.import_lib) then
AsmWrite(intf.import_lib^+'/');
AsmWriteln(intf.objextname^);
end;
end;
{ in case of nested class: relation to parent class }
if obj.owner.symtabletype in [objectsymtable,recordsymtable] then
AsmWriteln(InnerStructDef(obj));
{ all 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) 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;
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:=maybequoted(ScriptFixFileName(AsmFileName));
while not asmfiles.empty do
filenames:=filenames+' '+asmfiles.GetFirst;
Replace(result,'$ASM',filenames);
if (path<>'') then
Replace(result,'$OBJDIR',maybequoted(ScriptFixFileName(path)))
else
Replace(result,'$OBJDIR','.');
Replace(result,'$JASMINJAR',maybequoted(ScriptFixFileName(jasminjar)));
end;
procedure TJasminAssembler.NewAsmFileForStructDef(obj: tabstractrecorddef);
begin
if AsmSize<>AsmStartSize then
begin
AsmClose;
asmfiles.Concat(maybequoted(ScriptFixFileName(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): string;
begin
case vis of
vis_hidden,
vis_strictprivate:
result:='private ';
vis_strictprotected:
result:='protected ';
vis_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): string;
begin
result:=VisibilityToStr(pd.visibility);
if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or
(po_staticmethod in pd.procoptions) then
result:=result+'static ';
if 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(pd.proctypeoption in [potype_constructor,potype_class_constructor])) then
result:=result+'final ';
result:=result+pd.jvmmangledbasename;
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 64 bit values }
result:=tostr(csym.value.valueord.svalue);
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
result:=' = '+ConstValue(csym)
end;
end;
function TJasminAssembler.ConstDefinition(sym: tconstsym): string;
begin
result:=VisibilityToStr(sym.visibility);
{ formal constants are always class-level, not instance-level }
result:=result+'static final ';
result:=result+jvmmangledbasename(sym);
result:=result+ConstAssignmentValue(tconstsym(sym));
end;
function TJasminAssembler.FieldDefinition(sym: tabstractvarsym): string;
var
vissym: tabstractvarsym;
begin
vissym:=sym;
{ static field definition -> get original field definition for
visibility }
if (sym.typ=staticvarsym) and
(sym.owner.symtabletype=objectsymtable) then
begin
vissym:=tabstractvarsym(
tabstractrecorddef(sym.owner.defowner).symtable.find(
internal_static_field_name(sym.name)));
if not assigned(vissym) then
vissym:=tabstractvarsym(
tabstractrecorddef(sym.owner.defowner).symtable.find(
generate_nested_name(sym.owner,'_')+'_'+sym.name));
if not assigned(vissym) or
not(vissym.typ in [fieldvarsym,absolutevarsym]) then
internalerror(2011011501);
end;
case vissym.typ of
staticvarsym:
begin
if vissym.owner.symtabletype=globalsymtable then
result:='public '
else
{ package visbility }
result:='';
end;
fieldvarsym,
absolutevarsym:
result:=VisibilityToStr(tstoredsym(vissym).visibility);
else
internalerror(2011011204);
end;
if (sym.typ=staticvarsym) or
(sp_static in sym.symoptions) then
result:=result+'static ';
if sym.varspez=vs_const then
result:=result+'final ';
result:=result+jvmmangledbasename(sym);
end;
function TJasminAssembler.InnerStructDef(obj: tabstractrecorddef): string;
var
extname: pshortstring;
kindname: string;
begin
if not(obj.owner.defowner.typ in [objectdef,recorddef]) then
internalerror(2011021701);
case obj.typ of
recorddef:
begin
kindname:='class ';
extname:=obj.symtable.realname;
end;
objectdef:
begin
extname:=tobjectdef(obj).objextname;
case tobjectdef(obj).objecttype of
odt_javaclass:
kindname:='class ';
odt_interfacejava:
kindname:='interface ';
else
internalerror(2011021702);
end;
end;
else
internalerror(2011032809);
end;
result:=
'.inner '+
kindname+
VisibilityToStr(obj.typesym.visibility)+
{ 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 }
' static '+
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 is_javainterface(pd.struct) or
(pd.proctypeoption in [potype_unitinit,potype_unitfinalize])) then
exit;
AsmWrite('.method ');
AsmWriteln(MethodDefinition(pd));
WriteTree(pd.exprasmlist);
AsmWriteln('.end method');
AsmLn;
end;
procedure TJasminAssembler.WriteFieldSym(sym: tabstractvarsym);
begin
{ internal static field definition alias -> skip }
if sp_static in sym.symoptions 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
WriteConstSym(tconstsym(sym));
end;
procsym:
begin
for j:=0 to tprocsym(sym).procdeflist.count-1 do
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) 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]);
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;
{****************************************************************************}
{ Jasmin Instruction Writer }
{****************************************************************************}
constructor TJasminInstrWriter.create(_owner: TJasminAssembler);
begin
inherited create;
owner := _owner;
end;
function getreferencestring(var ref : treference) : string;
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: string[3];
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];
flags : [];
labelprefix : 'L';
comment : ' ; ';
);
begin
RegisterAssembler(as_jvm_jasmin_info,TJasminAssembler);
end.
Reference in New Issue View Git Blame Copy Permalink