1 { 2 Copyright (c) 1998-2010 by the Free Pascal team 3 4 This unit implements the Jasmin assembler writer 5 6 This program is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 2 of the License, or 9 (at your option) any later version. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 You should have received a copy of the GNU General Public License 17 along with this program; if not, write to the Free Software 18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 19 20 **************************************************************************** 21 } 22 { Unit for writing Jasmin assembler (JVM bytecode) output. 23 } 24 unit agjasmin; 25 26 {$i fpcdefs.inc} 27 28 interface 29 30 uses 31 cclasses,systems, 32 globtype,globals, 33 symconst,symbase,symdef,symsym, 34 aasmbase,aasmtai,aasmdata,aasmcpu, 35 assemble; 36 37 type 38 TJasminAssemblerOutputFile=class(TExternalAssemblerOutputFile) 39 procedure RemoveAsm; override; 40 end; 41 42 TJasminInstrWriter = class; 43 {# This is a derived class which is used to write 44 Jasmin-styled assembler. 45 } 46 47 { TJasminAssembler } 48 49 TJasminAssembler=class(texternalassembler) 50 protected 51 jasminjar: tcmdstr; 52 asmfiles: TCmdStrList; 53 54 procedure WriteExtraHeader(obj: tabstractrecorddef); 55 procedure WriteInstruction(hp: tai); 56 procedure NewAsmFileForStructDef(obj: tabstractrecorddef); 57 VisibilityToStrnull58 function VisibilityToStr(vis: tvisibility): ansistring; MethodDefinitionnull59 function MethodDefinition(pd: tprocdef): ansistring; ConstValuenull60 function ConstValue(csym: tconstsym): ansistring; ConstAssignmentValuenull61 function ConstAssignmentValue(csym: tconstsym): ansistring; ConstDefinitionnull62 function ConstDefinition(sym: tconstsym): ansistring; FieldDefinitionnull63 function FieldDefinition(sym: tabstractvarsym): ansistring; InnerStructDefnull64 function InnerStructDef(obj: tabstractrecorddef): ansistring; 65 66 procedure WriteProcDef(pd: tprocdef); 67 procedure WriteFieldSym(sym: tabstractvarsym); 68 procedure WriteConstSym(sym: tconstsym); 69 procedure WriteSymtableVarSyms(st: TSymtable); 70 procedure WriteSymtableProcdefs(st: TSymtable); 71 procedure WriteSymtableStructDefs(st: TSymtable); 72 CreateNewAsmWriternull73 function CreateNewAsmWriter: TExternalAssemblerOutputFile; override; 74 public 75 constructor CreateWithWriter(info: pasminfo; wr: TExternalAssemblerOutputFile; freewriter, smart: boolean); override; MakeCmdLinenull76 function MakeCmdLine: TCmdStr;override; 77 procedure WriteTree(p:TAsmList);override; 78 procedure WriteAsmList;override; 79 destructor destroy; override; 80 protected 81 InstrWriter: TJasminInstrWriter; 82 end; 83 84 85 {# This is the base class for writing instructions. 86 87 The WriteInstruction() method must be overridden 88 to write a single instruction to the assembler 89 file. 90 } 91 92 { TJasminInstrWriter } 93 94 TJasminInstrWriter = class 95 constructor create(_owner: TJasminAssembler); 96 procedure WriteInstruction(hp : tai); virtual; 97 protected 98 owner: TJasminAssembler; 99 end; 100 101 102 implementation 103 104 uses 105 SysUtils, 106 cutils,cfileutl,cscript, 107 fmodule,finput,verbose, 108 symtype,symcpu,symtable,jvmdef, 109 itcpujas,cpubase,cpuinfo,cgutils, 110 widestr 111 ; 112 113 const 114 line_length = 70; 115 116 type 117 t64bitarray = array[0..7] of byte; 118 t32bitarray = array[0..3] of byte; 119 120 {****************************************************************************} 121 { Support routines } 122 {****************************************************************************} 123 fixlinenull124 function fixline(s:string):string; 125 { 126 return s with all leading and ending spaces and tabs removed 127 } 128 var 129 i,j,k : integer; 130 begin 131 i:=length(s); 132 while (i>0) and (s[i] in [#9,' ']) do 133 dec(i); 134 j:=1; 135 while (j<i) and (s[j] in [#9,' ']) do 136 inc(j); 137 for k:=j to i do 138 if s[k] in [#0..#31,#127..#255] then 139 s[k]:='.'; 140 fixline:=Copy(s,j,i-j+1); 141 end; 142 143 constastrnull144 function constastr(p: pchar; len: longint): ansistring; 145 var 146 i,runstart,runlen: longint; 147 148 procedure flush; 149 begin 150 if runlen>0 then 151 begin 152 setlength(result,length(result)+runlen); 153 move(p[runstart],result[length(result)-runlen+1],runlen); 154 runlen:=0; 155 end; 156 end; 157 158 begin 159 result:='"'; 160 runlen:=0; 161 runstart:=0; 162 for i:=0 to len-1 do 163 begin 164 { escape control codes } 165 case p[i] of 166 { LF and CR must be escaped specially, because \uXXXX parsing 167 happens in the pre-processor, so it's the same as actually 168 inserting a newline in the middle of a string constant } 169 #10: 170 begin 171 flush; 172 result:=result+'\n'; 173 end; 174 #13: 175 begin 176 flush; 177 result:=result+'\r'; 178 end; 179 '"','\': 180 begin 181 flush; 182 result:=result+'\'+p[i]; 183 end 184 else if p[i]<#32 then 185 begin 186 flush; 187 result:=result+'\u'+hexstr(ord(p[i]),4); 188 end 189 else if p[i]<#127 then 190 begin 191 if runlen=0 then 192 runstart:=i; 193 inc(runlen); 194 end 195 else 196 begin 197 { see comments in njvmcon } 198 flush; 199 result:=result+'\u'+hexstr(ord(p[i]),4) 200 end; 201 end; 202 end; 203 flush; 204 result:=result+'"'; 205 end; 206 207 constwstrnull208 function constwstr(w: pcompilerwidechar; len: longint): ansistring; 209 var 210 i: longint; 211 begin 212 result:='"'; 213 for i:=0 to len-1 do 214 begin 215 { escape control codes } 216 case w[i] of 217 10: 218 result:=result+'\n'; 219 13: 220 result:=result+'\r'; 221 ord('"'),ord('\'): 222 result:=result+'\'+chr(w[i]); 223 else if (w[i]<32) or 224 (w[i]>=127) then 225 result:=result+'\u'+hexstr(w[i],4) 226 else 227 result:=result+char(w[i]); 228 end; 229 end; 230 result:=result+'"'; 231 end; 232 233 constsinglenull234 function constsingle(s: single): ansistring; 235 begin 236 result:='0fx'+hexstr(longint(t32bitarray(s)),8); 237 end; 238 239 constdoublenull240 function constdouble(d: double): ansistring; 241 begin 242 // force interpretation as double (since we write it out as an 243 // integer, we never have to swap the endianess). We have to 244 // include the sign separately because of the way Java parses 245 // hex numbers (0x8000000000000000 is not a valid long) 246 result:=hexstr(abs(int64(t64bitarray(d))),16); 247 if int64(t64bitarray(d))<0 then 248 result:='-'+result; 249 result:='0dx'+result; 250 end; 251 252 253 {****************************************************************************} 254 { Jasmin Output File } 255 {****************************************************************************} 256 257 procedure TJasminAssemblerOutputFile.RemoveAsm; 258 var 259 g : file; 260 begin 261 inherited; 262 if cs_asm_leave in current_settings.globalswitches then 263 exit; 264 while not TJasminAssembler(owner).asmfiles.empty do 265 begin 266 if cs_asm_extern in current_settings.globalswitches then 267 AsmRes.AddDeleteCommand(TJasminAssembler(owner).asmfiles.GetFirst) 268 else 269 begin 270 assign(g,TJasminAssembler(owner).asmfiles.GetFirst); 271 {$I-} 272 erase(g); 273 {$I+} 274 if ioresult<>0 then; 275 end; 276 end; 277 end; 278 279 280 {****************************************************************************} 281 { Jasmin Assembler writer } 282 {****************************************************************************} 283 284 destructor TJasminAssembler.Destroy; 285 begin 286 InstrWriter.free; 287 asmfiles.free; 288 inherited destroy; 289 end; 290 291 292 procedure TJasminAssembler.WriteTree(p:TAsmList); 293 var 294 ch : char; 295 hp : tai; 296 hp1 : tailineinfo; 297 s : ansistring; 298 i,pos : longint; 299 InlineLevel : longint; 300 do_line : boolean; 301 begin 302 if not assigned(p) then 303 exit; 304 305 InlineLevel:=0; 306 { lineinfo is only needed for al_procedures (PFV) } 307 do_line:=(cs_asm_source in current_settings.globalswitches); 308 hp:=tai(p.first); 309 while assigned(hp) do 310 begin 311 prefetch(pointer(hp.next)^); 312 if not(hp.typ in SkipLineInfo) then 313 begin 314 hp1 := hp as tailineinfo; 315 current_filepos:=hp1.fileinfo; 316 { no line info for inlined code } 317 if do_line and (inlinelevel=0) then 318 begin 319 { load infile } 320 if lastfileinfo.fileindex<>hp1.fileinfo.fileindex then 321 begin 322 infile:=current_module.sourcefiles.get_file(hp1.fileinfo.fileindex); 323 if assigned(infile) then 324 begin 325 { open only if needed !! } 326 if (cs_asm_source in current_settings.globalswitches) then 327 infile.open; 328 end; 329 { avoid unnecessary reopens of the same file !! } 330 lastfileinfo.fileindex:=hp1.fileinfo.fileindex; 331 { be sure to change line !! } 332 lastfileinfo.line:=-1; 333 end; 334 335 { write source } 336 if (cs_asm_source in current_settings.globalswitches) and 337 assigned(infile) then 338 begin 339 if (infile<>lastinfile) then 340 begin 341 writer.AsmWriteLn(asminfo^.comment+'['+infile.name+']'); 342 if assigned(lastinfile) then 343 lastinfile.close; 344 end; 345 if (hp1.fileinfo.line<>lastfileinfo.line) and 346 ((hp1.fileinfo.line<infile.maxlinebuf) or (InlineLevel>0)) then 347 begin 348 if (hp1.fileinfo.line<>0) and 349 ((infile.linebuf^[hp1.fileinfo.line]>=0) or (InlineLevel>0)) then 350 writer.AsmWriteLn(asminfo^.comment+'['+tostr(hp1.fileinfo.line)+'] '+ 351 fixline(infile.GetLineStr(hp1.fileinfo.line))); 352 { set it to a negative value ! 353 to make that is has been read already !! PM } 354 if (infile.linebuf^[hp1.fileinfo.line]>=0) then 355 infile.linebuf^[hp1.fileinfo.line]:=-infile.linebuf^[hp1.fileinfo.line]-1; 356 end; 357 end; 358 lastfileinfo:=hp1.fileinfo; 359 lastinfile:=infile; 360 end; 361 end; 362 363 case hp.typ of 364 365 ait_comment : 366 Begin 367 writer.AsmWrite(asminfo^.comment); 368 writer.AsmWritePChar(tai_comment(hp).str); 369 writer.AsmLn; 370 End; 371 372 ait_regalloc : 373 begin 374 if (cs_asm_regalloc in current_settings.globalswitches) then 375 begin 376 writer.AsmWrite(#9+asminfo^.comment+'Register '); 377 repeat 378 writer.AsmWrite(std_regname(Tai_regalloc(hp).reg)); 379 if (hp.next=nil) or 380 (tai(hp.next).typ<>ait_regalloc) or 381 (tai_regalloc(hp.next).ratype<>tai_regalloc(hp).ratype) then 382 break; 383 hp:=tai(hp.next); 384 writer.AsmWrite(','); 385 until false; 386 writer.AsmWrite(' '); 387 writer.AsmWriteLn(regallocstr[tai_regalloc(hp).ratype]); 388 end; 389 end; 390 391 ait_tempalloc : 392 begin 393 if (cs_asm_tempalloc in current_settings.globalswitches) then 394 begin 395 {$ifdef EXTDEBUG} 396 if assigned(tai_tempalloc(hp).problem) then 397 writer.AsmWriteLn(asminfo^.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+ 398 tostr(tai_tempalloc(hp).tempsize)+' '+tai_tempalloc(hp).problem^) 399 else 400 {$endif EXTDEBUG} 401 writer.AsmWriteLn(asminfo^.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+ 402 tostr(tai_tempalloc(hp).tempsize)+' '+tempallocstr[tai_tempalloc(hp).allocation]); 403 end; 404 end; 405 406 ait_align : 407 begin 408 409 end; 410 411 ait_section : 412 begin 413 414 end; 415 416 ait_datablock : 417 begin 418 internalerror(2010122701); 419 end; 420 421 ait_const: 422 begin 423 writer.AsmWriteln('constant'); 424 // internalerror(2010122702); 425 end; 426 427 ait_realconst : 428 begin 429 internalerror(2010122703); 430 end; 431 432 ait_string : 433 begin 434 pos:=0; 435 for i:=1 to tai_string(hp).len do 436 begin 437 if pos=0 then 438 begin 439 writer.AsmWrite(#9'strconst: '#9'"'); 440 pos:=20; 441 end; 442 ch:=tai_string(hp).str[i-1]; 443 case ch of 444 #0, {This can't be done by range, because a bug in FPC} 445 #1..#31, 446 #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7); 447 '"' : s:='\"'; 448 '\' : s:='\\'; 449 else 450 s:=ch; 451 end; 452 writer.AsmWrite(s); 453 inc(pos,length(s)); 454 if (pos>line_length) or (i=tai_string(hp).len) then 455 begin 456 writer.AsmWriteLn('"'); 457 pos:=0; 458 end; 459 end; 460 end; 461 462 ait_label : 463 begin 464 if (tai_label(hp).labsym.is_used) then 465 begin 466 writer.AsmWrite(tai_label(hp).labsym.name); 467 writer.AsmWriteLn(':'); 468 end; 469 end; 470 471 ait_symbol : 472 begin thennull473 if (tai_symbol(hp).sym.typ = AT_FUNCTION) then 474 begin 475 end 476 else 477 begin 478 writer.AsmWrite('data symbol: '); 479 writer.AsmWriteln(tai_symbol(hp).sym.name); 480 // internalerror(2010122706); 481 end; 482 end; 483 ait_symbol_end : 484 begin 485 end; 486 487 ait_instruction : 488 begin 489 WriteInstruction(hp); 490 end; 491 492 ait_force_line, 493 ait_function_name : ; 494 495 ait_cutobject : 496 begin 497 end; 498 499 ait_marker : 500 if tai_marker(hp).kind=mark_NoLineInfoStart then 501 inc(InlineLevel) 502 else if tai_marker(hp).kind=mark_NoLineInfoEnd then 503 dec(InlineLevel); 504 505 ait_directive : 506 begin 507 { the CPU directive is probably not supported by the JVM assembler, 508 so it's commented out } 509 if tai_directive(hp).directive=asd_cpu then 510 writer.AsmWrite(asminfo^.comment); 511 writer.AsmWrite('.'+directivestr[tai_directive(hp).directive]+' '); 512 if tai_directive(hp).name<>'' then 513 writer.AsmWrite(tai_directive(hp).name); 514 writer.AsmLn; 515 end; 516 517 ait_jvar: 518 begin 519 writer.AsmWrite('.var '); 520 writer.AsmWrite(tostr(tai_jvar(hp).stackslot)); 521 writer.AsmWrite(' is '); 522 writer.AsmWrite(tai_jvar(hp).desc^); 523 writer.AsmWrite(' from '); 524 writer.AsmWrite(tai_jvar(hp).startlab.name); 525 writer.AsmWrite(' to '); 526 writer.AsmWriteLn(tai_jvar(hp).stoplab.name); 527 end; 528 529 ait_jcatch: 530 begin 531 writer.AsmWrite('.catch '); 532 writer.AsmWrite(tai_jcatch(hp).name^); 533 writer.AsmWrite(' from '); 534 writer.AsmWrite(tai_jcatch(hp).startlab.name); 535 writer.AsmWrite(' to '); 536 writer.AsmWrite(tai_jcatch(hp).stoplab.name); 537 writer.AsmWrite(' using '); 538 writer.AsmWriteLn(tai_jcatch(hp).handlerlab.name); 539 end; 540 else 541 internalerror(2010122707); 542 end; 543 hp:=tai(hp.next); 544 end; 545 end; 546 547 548 procedure TJasminAssembler.WriteExtraHeader(obj: tabstractrecorddef); 549 var 550 superclass, 551 intf: tobjectdef; 552 n: ansistring; 553 i: longint; 554 toplevelowner: tsymtable; 555 begin 556 superclass:=nil; 557 558 { JVM 1.5+ } 559 writer.AsmWriteLn('.bytecode 49.0'); 560 // include files are not support by Java, and the directory of the main 561 // source file must not be specified 562 if current_module.mainsource<>'' then 563 n:=ExtractFileName(current_module.mainsource) 564 else 565 n:=InputFileName; 566 writer.AsmWriteLn('.source '+ExtractFileName(n)); 567 568 { class/interface name } 569 if not assigned(obj) then 570 begin 571 { fake class type for unit -> name=unitname and 572 superclass=java.lang.object, make final so you cannot descend 573 from it } 574 writer.AsmWrite('.class final public '); 575 if assigned(current_module.namespace) then 576 writer.AsmWrite(current_module.namespace^+'.'); 577 writer.AsmWriteln(current_module.realmodulename^); 578 writer.AsmWriteLn('.super java/lang/Object'); 579 end 580 else 581 begin 582 toplevelowner:=obj.owner; 583 while not(toplevelowner.symtabletype in [staticsymtable,globalsymtable]) do 584 toplevelowner:=toplevelowner.defowner.owner; 585 case obj.typ of 586 recorddef: 587 begin 588 { can't inherit from records } 589 writer.AsmWrite('.class final '); 590 if toplevelowner.symtabletype=globalsymtable then 591 writer.AsmWrite('public '); 592 writer.AsmWriteln(obj.jvm_full_typename(true)); 593 superclass:=java_fpcbaserecordtype; 594 end; 595 objectdef: 596 begin 597 case tobjectdef(obj).objecttype of 598 odt_javaclass: 599 begin 600 writer.AsmWrite('.class '); 601 if oo_is_sealed in tobjectdef(obj).objectoptions then 602 writer.AsmWrite('final '); 603 if (oo_is_abstract in tobjectdef(obj).objectoptions) or 604 (tobjectdef(obj).abstractcnt<>0) then 605 writer.AsmWrite('abstract '); 606 if toplevelowner.symtabletype=globalsymtable then 607 writer.AsmWrite('public '); 608 if (oo_is_enum_class in tobjectdef(obj).objectoptions) then 609 writer.AsmWrite('enum '); 610 writer.AsmWriteln(obj.jvm_full_typename(true)); 611 superclass:=tobjectdef(obj).childof; 612 end; 613 odt_interfacejava: 614 begin 615 writer.AsmWrite('.interface abstract '); 616 if toplevelowner.symtabletype=globalsymtable then 617 writer.AsmWrite('public '); 618 writer.AsmWriteLn(obj.jvm_full_typename(true)); 619 { interfaces must always specify Java.lang.object as 620 superclass } 621 superclass:=java_jlobject; 622 end 623 else 624 internalerror(2011010906); 625 end; 626 end; 627 end; 628 { superclass } 629 if assigned(superclass) then 630 begin 631 writer.AsmWrite('.super '); 632 if assigned(superclass.import_lib) then 633 writer.AsmWrite(superclass.import_lib^+'/'); 634 writer.AsmWriteln(superclass.objextname^); 635 end; 636 { implemented interfaces } 637 if (obj.typ=objectdef) and 638 assigned(tobjectdef(obj).ImplementedInterfaces) then 639 begin 640 for i:=0 to tobjectdef(obj).ImplementedInterfaces.count-1 do 641 begin 642 intf:=TImplementedInterface(tobjectdef(obj).ImplementedInterfaces[i]).IntfDef; 643 writer.AsmWrite('.implements '); 644 writer.AsmWriteLn(intf.jvm_full_typename(true)); 645 end; 646 end; 647 { signature for enum classes (must come after superclass and 648 implemented interfaces) } 649 if (obj.typ=objectdef) and 650 (oo_is_enum_class in tobjectdef(obj).objectoptions) then 651 writer.AsmWriteln('.signature "Ljava/lang/Enum<L'+obj.jvm_full_typename(true)+';>;"'); 652 { in case of nested class: relation to parent class } 653 if obj.owner.symtabletype in [objectsymtable,recordsymtable] then 654 writer.AsmWriteln(InnerStructDef(obj)); 655 { add all nested classes } 656 for i:=0 to obj.symtable.deflist.count-1 do 657 if (is_java_class_or_interface(tdef(obj.symtable.deflist[i])) or 658 (tdef(obj.symtable.deflist[i]).typ=recorddef)) and 659 not(df_generic in tdef(obj.symtable.deflist[i]).defoptions) then 660 writer.AsmWriteln(InnerStructDef(tabstractrecorddef(obj.symtable.deflist[i]))); 661 end; 662 writer.AsmLn; 663 end; 664 665 666 procedure TJasminAssembler.WriteInstruction(hp: tai); 667 begin 668 InstrWriter.WriteInstruction(hp); 669 end; 670 671 TJasminAssembler.MakeCmdLinenull672 function TJasminAssembler.MakeCmdLine: TCmdStr; 673 const 674 jasminjarname = 'jasmin.jar'; 675 var 676 filenames: tcmdstr; 677 asmfile: tcmdstrlistitem; 678 jasminjarfound: boolean; 679 begin 680 if jasminjar='' then 681 begin 682 jasminjarfound:=false; 683 if utilsdirectory<>'' then 684 jasminjarfound:=FindFile(jasminjarname,utilsdirectory,false,jasminjar); 685 if not jasminjarfound then 686 jasminjarfound:=FindFileInExeLocations(jasminjarname,false,jasminjar); 687 if (not jasminjarfound) and not(cs_asm_extern in current_settings.globalswitches) then 688 begin 689 Message1(exec_e_assembler_not_found,jasminjarname); 690 current_settings.globalswitches:=current_settings.globalswitches+[cs_asm_extern]; 691 end; 692 if jasminjarfound then 693 Message1(exec_t_using_assembler,jasminjar); 694 end; 695 result:=asminfo^.asmcmd; 696 filenames:=ScriptFixFileName(AsmFileName); 697 if cs_asm_extern in current_settings.globalswitches then 698 filenames:=maybequoted(filenames); 699 asmfile:=tcmdstrlistitem(asmfiles.First); 700 while assigned(asmfile) do 701 begin 702 if cs_asm_extern in current_settings.globalswitches then 703 filenames:=filenames+' '+maybequoted(ScriptFixFileName(asmfile.str)) 704 else 705 filenames:=filenames+' '+ScriptFixFileName(asmfile.str); 706 asmfile:=tcmdstrlistitem(asmfile.next); 707 end; 708 Replace(result,'$ASM',filenames); 709 if (path<>'') then 710 if cs_asm_extern in current_settings.globalswitches then 711 Replace(result,'$OBJDIR',maybequoted(ScriptFixFileName(path))) 712 else 713 Replace(result,'$OBJDIR',ScriptFixFileName(path)) 714 else 715 Replace(result,'$OBJDIR','.'); 716 if cs_asm_extern in current_settings.globalswitches then 717 Replace(result,'$JASMINJAR',maybequoted(ScriptFixFileName(jasminjar))) 718 else 719 Replace(result,'$JASMINJAR',ScriptFixFileName(jasminjar)); 720 Replace(result,'$EXTRAOPT',asmextraopt); 721 end; 722 723 724 procedure TJasminAssembler.NewAsmFileForStructDef(obj: tabstractrecorddef); 725 begin 726 if not writer.ClearIfEmpty then 727 begin 728 writer.AsmClose; 729 asmfiles.Concat(AsmFileName); 730 end; 731 732 AsmFileName:=obj.jvm_full_typename(false); 733 AsmFileName:=Path+FixFileName(AsmFileName)+target_info.asmext; 734 writer.AsmCreate(cut_normal); 735 end; 736 737 TJasminAssembler.VisibilityToStrnull738 function TJasminAssembler.VisibilityToStr(vis: tvisibility): ansistring; 739 begin 740 case vis of 741 vis_hidden, 742 vis_strictprivate: 743 result:='private '; 744 { protected in Java means "accessible by subclasses *and* by classes 745 in the same package" -> similar to regular "protected" in Pascal; 746 "strict protected" is actually more strict in Pascal than in Java, 747 but there's not much we can do about that } 748 vis_protected, 749 vis_strictprotected: 750 result:='protected '; 751 vis_private: 752 { pick default visibility = "package" visibility; required because 753 other classes in the same unit can also access these symbols } 754 result:=''; 755 vis_public: 756 result:='public ' 757 else 758 internalerror(2010122609); 759 end; 760 end; 761 762 TJasminAssembler.MethodDefinitionnull763 function TJasminAssembler.MethodDefinition(pd: tprocdef): ansistring; 764 begin 765 result:=VisibilityToStr(pd.visibility); 766 if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or 767 (po_classmethod in pd.procoptions) then 768 result:=result+'static '; 769 if (po_abstractmethod in pd.procoptions) or 770 is_javainterface(tdef(pd.owner.defowner)) then 771 result:=result+'abstract '; 772 if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or 773 (po_finalmethod in pd.procoptions) or 774 (not(po_virtualmethod in pd.procoptions) and 775 not(po_classmethod in pd.procoptions) and 776 not(pd.proctypeoption in [potype_constructor,potype_class_constructor])) then 777 result:=result+'final '; 778 result:=result+tcpuprocdef(pd).jvmmangledbasename(false); 779 end; 780 781 TJasminAssembler.ConstValuenull782 function TJasminAssembler.ConstValue(csym: tconstsym): ansistring; 783 begin 784 case csym.consttyp of 785 constord: 786 { always interpret as signed value, because the JVM does not 787 support unsigned values } 788 case csym.constdef.size of 789 1:result:=tostr(shortint(csym.value.valueord.svalue)); 790 2:result:=tostr(smallint(csym.value.valueord.svalue)); 791 4:result:=tostr(longint(csym.value.valueord.svalue)); 792 8:result:=tostr(csym.value.valueord.svalue); 793 else 794 internalerror(2014082050); 795 end; 796 conststring: 797 result:=constastr(pchar(csym.value.valueptr),csym.value.len); 798 constreal: 799 case tfloatdef(csym.constdef).floattype of 800 s32real: 801 result:=constsingle(pbestreal(csym.value.valueptr)^); 802 s64real: 803 result:=constdouble(pbestreal(csym.value.valueptr)^); 804 else 805 internalerror(2011021204); 806 end; 807 constset: 808 result:='TODO: add support for constant sets'; 809 constpointer: 810 { can only be null, but that's the default value and should not 811 be written; there's no primitive type that can hold nill } 812 internalerror(2011021201); 813 constnil: 814 internalerror(2011021202); 815 constresourcestring: 816 result:='TODO: add support for constant resource strings'; 817 constwstring: 818 result:=constwstr(pcompilerwidestring(csym.value.valueptr)^.data,pcompilerwidestring(csym.value.valueptr)^.len); 819 constguid: 820 result:='TODO: add support for constant guids'; 821 else 822 internalerror(2011021205); 823 end; 824 end; 825 826 TJasminAssembler.ConstAssignmentValuenull827 function TJasminAssembler.ConstAssignmentValue(csym: tconstsym): ansistring; 828 begin 829 result:=''; 830 { nil is the default value -> don't write explicitly } 831 case csym.consttyp of 832 constpointer: 833 begin 834 if csym.value.valueordptr<>0 then 835 internalerror(2011021206); 836 end; 837 constnil: 838 ; 839 else 840 begin 841 { enums and sets are initialized as typed constants } 842 if not assigned(csym.constdef) or 843 not(csym.constdef.typ in [enumdef,setdef]) then 844 result:=' = '+ConstValue(csym); 845 end; 846 end; 847 end; 848 849 TJasminAssembler.ConstDefinitionnull850 function TJasminAssembler.ConstDefinition(sym: tconstsym): ansistring; 851 begin 852 result:=VisibilityToStr(sym.visibility); 853 { formal constants are always class-level, not instance-level } 854 result:=result+'static final '; 855 if sp_internal in sym.symoptions then 856 result:=result+'synthetic '; 857 result:=result+jvmmangledbasename(sym,true); 858 result:=result+ConstAssignmentValue(tconstsym(sym)); 859 end; 860 861 TJasminAssembler.FieldDefinitionnull862 function TJasminAssembler.FieldDefinition(sym: tabstractvarsym): ansistring; 863 begin 864 case sym.typ of 865 staticvarsym: 866 begin 867 if sym.owner.symtabletype=globalsymtable then 868 result:='public ' 869 else 870 { package visbility } 871 result:=''; 872 end; 873 fieldvarsym, 874 absolutevarsym: 875 result:=VisibilityToStr(tstoredsym(sym).visibility); 876 else 877 internalerror(2011011204); 878 end; 879 if (sym.typ=staticvarsym) or 880 (sp_static in sym.symoptions) then 881 result:=result+'static '; 882 if sym.varspez in [vs_const,vs_final] then 883 result:=result+'final '; 884 if sp_internal in sym.symoptions then 885 result:=result+'synthetic '; 886 { mark the class fields of enum classes that contain the initialised 887 enum instances as "enum" (recognise them by the fact that their type 888 is the same as their parent class, and that this parent class is 889 marked as oo_is_enum_class) } 890 if assigned(sym.owner.defowner) and 891 (tdef(sym.owner.defowner).typ=objectdef) and 892 (oo_is_enum_class in tobjectdef(sym.owner.defowner).objectoptions) and 893 (sym.typ=staticvarsym) and 894 (tstaticvarsym(sym).vardef=tdef(sym.owner.defowner)) then 895 result:=result+'enum '; 896 result:=result+jvmmangledbasename(sym,true); 897 end; 898 899 TJasminAssembler.InnerStructDefnull900 function TJasminAssembler.InnerStructDef(obj: tabstractrecorddef): ansistring; 901 var 902 extname: pshortstring; 903 kindname: ansistring; 904 begin 905 if not(obj.owner.defowner.typ in [objectdef,recorddef]) then 906 internalerror(2011021701); 907 { Nested classes in the Pascal sense are equivalent to "static" 908 inner classes in Java -- will be changed when support for 909 Java-style non-static classes is added } 910 case obj.typ of 911 recorddef: 912 begin 913 kindname:='class static '; 914 extname:=obj.symtable.realname; 915 end; 916 objectdef: 917 begin 918 extname:=tobjectdef(obj).objextname; 919 case tobjectdef(obj).objecttype of 920 odt_javaclass: 921 kindname:='class static '; 922 odt_interfacejava: 923 kindname:='interface static abstract '; 924 else 925 internalerror(2011021702); 926 end; 927 end; 928 else 929 internalerror(2011032809); 930 end; 931 result:= 932 '.inner '+ 933 kindname+ 934 VisibilityToStr(obj.typesym.visibility)+ 935 extname^+ 936 ' inner '+ 937 obj.jvm_full_typename(true)+ 938 ' outer '+ 939 tabstractrecorddef(obj.owner.defowner).jvm_full_typename(true); 940 end; 941 942 943 procedure TJasminAssembler.WriteProcDef(pd: tprocdef); 944 begin 945 if not assigned(tcpuprocdef(pd).exprasmlist) and 946 not(po_abstractmethod in pd.procoptions) and 947 (not is_javainterface(pd.struct) or 948 (pd.proctypeoption in [potype_unitinit,potype_unitfinalize])) then 949 exit; 950 writer.AsmWrite('.method '); 951 writer.AsmWriteln(MethodDefinition(pd)); 952 if jvmtypeneedssignature(pd) then 953 begin 954 writer.AsmWrite('.signature "'); 955 writer.AsmWrite(tcpuprocdef(pd).jvmmangledbasename(true)); 956 writer.AsmWriteln('"'); 957 end; 958 WriteTree(tcpuprocdef(pd).exprasmlist); 959 writer.AsmWriteln('.end method'); 960 writer.AsmLn; 961 end; 962 963 964 procedure TJasminAssembler.WriteFieldSym(sym: tabstractvarsym); 965 begin 966 { internal static field definition alias -> skip } 967 if (sym.owner.symtabletype in [recordsymtable,ObjectSymtable]) and 968 (sym.typ=staticvarsym) then 969 exit; 970 { external or threadvar definition -> no definition here } 971 if ([vo_is_external,vo_is_thread_var]*sym.varoptions)<>[] then 972 exit; 973 writer.AsmWrite('.field '); 974 writer.AsmWriteln(FieldDefinition(sym)); 975 end; 976 977 978 procedure TJasminAssembler.WriteConstSym(sym: tconstsym); 979 begin 980 writer.AsmWrite('.field '); 981 writer.AsmWriteln(ConstDefinition(sym)); 982 end; 983 984 985 procedure TJasminAssembler.WriteSymtableVarSyms(st: TSymtable); 986 var 987 sym : tsym; 988 i,j : longint; 989 begin 990 if not assigned(st) then 991 exit; 992 for i:=0 to st.SymList.Count-1 do 993 begin 994 sym:=tsym(st.SymList[i]); 995 case sym.typ of 996 staticvarsym, 997 fieldvarsym: 998 begin 999 WriteFieldSym(tabstractvarsym(sym)); 1000 if (sym.typ=staticvarsym) and 1001 assigned(tstaticvarsym(sym).defaultconstsym) then 1002 WriteFieldSym(tabstractvarsym(tstaticvarsym(sym).defaultconstsym)); 1003 end; 1004 constsym: 1005 begin 1006 { multiple procedures can have constants with the same name } 1007 if not assigned(sym.owner.defowner) or 1008 (tdef(sym.owner.defowner).typ<>procdef) then 1009 WriteConstSym(tconstsym(sym)); 1010 end; 1011 procsym: 1012 begin 1013 for j:=0 to tprocsym(sym).procdeflist.count-1 do 1014 if not(df_generic in tprocdef(tprocsym(sym).procdeflist[j]).defoptions) then 1015 WriteSymtableVarSyms(tprocdef(tprocsym(sym).procdeflist[j]).localst); 1016 end; 1017 end; 1018 end; 1019 end; 1020 1021 1022 procedure TJasminAssembler.WriteSymtableProcdefs(st: TSymtable); 1023 var 1024 i : longint; 1025 def : tdef; 1026 begin 1027 if not assigned(st) then 1028 exit; 1029 for i:=0 to st.DefList.Count-1 do 1030 begin 1031 def:=tdef(st.DefList[i]); 1032 case def.typ of 1033 procdef : 1034 begin 1035 { methods are also in the static/globalsymtable of the unit 1036 -> make sure they are only written for the objectdefs that 1037 own them } 1038 if (not(st.symtabletype in [staticsymtable,globalsymtable]) or 1039 (def.owner=st)) and 1040 not(df_generic in def.defoptions) then 1041 begin 1042 WriteProcDef(tprocdef(def)); 1043 if assigned(tprocdef(def).localst) then 1044 WriteSymtableProcdefs(tprocdef(def).localst); 1045 end; 1046 end; 1047 end; 1048 end; 1049 end; 1050 1051 procedure TJasminAssembler.WriteSymtableStructDefs(st: TSymtable); 1052 var 1053 i : longint; 1054 def : tdef; 1055 obj : tabstractrecorddef; 1056 nestedstructs: tfpobjectlist; 1057 begin 1058 if not assigned(st) then 1059 exit; 1060 nestedstructs:=tfpobjectlist.create(false); 1061 for i:=0 to st.DefList.Count-1 do 1062 begin 1063 def:=tdef(st.DefList[i]); 1064 if df_generic in def.defoptions then 1065 continue; 1066 case def.typ of 1067 objectdef: 1068 if not(oo_is_external in tobjectdef(def).objectoptions) then 1069 nestedstructs.add(def); 1070 recorddef: 1071 nestedstructs.add(def); 1072 end; 1073 end; 1074 for i:=0 to nestedstructs.count-1 do 1075 begin 1076 obj:=tabstractrecorddef(nestedstructs[i]); 1077 NewAsmFileForStructDef(obj); 1078 WriteExtraHeader(obj); 1079 WriteSymtableVarSyms(obj.symtable); 1080 writer.AsmLn; 1081 WriteSymtableProcDefs(obj.symtable); 1082 WriteSymtableStructDefs(obj.symtable); 1083 end; 1084 nestedstructs.free; 1085 end; 1086 1087 TJasminAssembler.CreateNewAsmWriternull1088 function TJasminAssembler.CreateNewAsmWriter: TExternalAssemblerOutputFile; 1089 begin 1090 Result:=TJasminAssemblerOutputFile.Create(self); 1091 end; 1092 1093 1094 constructor TJasminAssembler.CreateWithWriter(info: pasminfo; wr: TExternalAssemblerOutputFile; freewriter, smart: boolean); 1095 begin 1096 inherited; 1097 InstrWriter:=TJasminInstrWriter.Create(self); 1098 asmfiles:=TCmdStrList.Create; 1099 end; 1100 1101 1102 procedure TJasminAssembler.WriteAsmList; 1103 begin 1104 { the code for Java methods needs to be emitted class per class, 1105 so instead of iterating over all asmlists, we iterate over all types 1106 and global variables (a unit becomes a class, with its global 1107 variables static fields) } 1108 writer.MarkEmpty; 1109 WriteExtraHeader(nil); 1110 { print all global variables } 1111 WriteSymtableVarSyms(current_module.globalsymtable); 1112 WriteSymtableVarSyms(current_module.localsymtable); 1113 writer.AsmLn; 1114 { print all global procedures/functions } 1115 WriteSymtableProcdefs(current_module.globalsymtable); 1116 WriteSymtableProcdefs(current_module.localsymtable); 1117 1118 WriteSymtableStructDefs(current_module.globalsymtable); 1119 WriteSymtableStructDefs(current_module.localsymtable); 1120 1121 writer.AsmLn; 1122 end; 1123 1124 1125 {****************************************************************************} 1126 { Jasmin Instruction Writer } 1127 {****************************************************************************} 1128 1129 constructor TJasminInstrWriter.create(_owner: TJasminAssembler); 1130 begin 1131 inherited create; 1132 owner := _owner; 1133 end; 1134 getreferencestringnull1135 function getreferencestring(var ref : treference) : ansistring; 1136 begin 1137 if (ref.arrayreftype<>art_none) or 1138 (ref.index<>NR_NO) then 1139 internalerror(2010122809); 1140 if assigned(ref.symbol) then 1141 begin 1142 // global symbol or field -> full type and name 1143 // ref.base can be <> NR_NO in case an instance field is loaded. 1144 // This register is not part of this instruction, it will have 1145 // been placed on the stack by the previous one. 1146 if (ref.offset<>0) then 1147 internalerror(2010122811); 1148 result:=ref.symbol.name; 1149 end 1150 else 1151 begin 1152 // local symbol -> stack slot, stored in offset 1153 if ref.base<>NR_STACK_POINTER_REG then 1154 internalerror(2010122810); 1155 result:=tostr(ref.offset); 1156 end; 1157 end; 1158 1159 getopstrnull1160 function getopstr(const o:toper) : ansistring; 1161 var 1162 d: double; 1163 s: single; 1164 begin 1165 case o.typ of 1166 top_reg: 1167 // should have been translated into a memory location by the 1168 // register allocator) 1169 if (cs_no_regalloc in current_settings.globalswitches) then 1170 getopstr:=std_regname(o.reg) 1171 else 1172 internalerror(2010122803); 1173 top_const: 1174 str(o.val,result); 1175 top_ref: 1176 getopstr:=getreferencestring(o.ref^); 1177 top_single: 1178 begin 1179 result:=constsingle(o.sval); 1180 end; 1181 top_double: 1182 begin 1183 result:=constdouble(o.dval); 1184 end; 1185 top_string: 1186 begin 1187 result:=constastr(o.pcval,o.pcvallen); 1188 end; 1189 top_wstring: 1190 begin 1191 result:=constwstr(o.pwstrval^.data,getlengthwidestring(o.pwstrval)); 1192 end 1193 else 1194 internalerror(2010122802); 1195 end; 1196 end; 1197 1198 1199 procedure TJasminInstrWriter.WriteInstruction(hp: tai); 1200 var 1201 s: ansistring; 1202 i: byte; 1203 sep: ansistring; 1204 begin 1205 s:=#9+jas_op2str[taicpu(hp).opcode]; 1206 if taicpu(hp).ops<>0 then 1207 begin 1208 sep:=#9; 1209 for i:=0 to taicpu(hp).ops-1 do 1210 begin 1211 s:=s+sep+getopstr(taicpu(hp).oper[i]^); 1212 sep:=' '; 1213 end; 1214 end; 1215 owner.writer.AsmWriteLn(s); 1216 end; 1217 1218 {****************************************************************************} 1219 { Jasmin Instruction Writer } 1220 {****************************************************************************} 1221 1222 const 1223 as_jvm_jasmin_info : tasminfo = 1224 ( 1225 id : as_jvm_jasmin; 1226 idtxt : 'Jasmin'; 1227 asmbin : 'java'; 1228 asmcmd : '-jar $JASMINJAR $ASM $EXTRAOPT -d $OBJDIR'; 1229 supported_targets : [system_jvm_java32,system_jvm_android32]; 1230 flags : []; 1231 labelprefix : 'L'; 1232 comment : ' ; '; 1233 dollarsign : '$'; 1234 ); 1235 1236 1237 begin 1238 RegisterAssembler(as_jvm_jasmin_info,TJasminAssembler); 1239 end. 1240