hlcgcpu.pas 101 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583
  1. {
  2. Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
  3. Member of the Free Pascal development team
  4. This unit implements the jvm high level code generator
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit hlcgcpu;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. globtype,
  23. aasmbase,aasmdata,
  24. symbase,symconst,symtype,symdef,symsym,
  25. node,
  26. cpubase, hlcgobj, cgbase, cgutils, parabase;
  27. type
  28. { thlcgjvm }
  29. thlcgjvm = class(thlcgobj)
  30. private
  31. fevalstackheight,
  32. fmaxevalstackheight: longint;
  33. public
  34. constructor create;
  35. procedure incstack(list : TAsmList;slots: longint);
  36. procedure decstack(list : TAsmList;slots: longint);
  37. class function def2regtyp(def: tdef): tregistertype; override;
  38. procedure a_load_const_cgpara(list : TAsmList;tosize : tdef;a : tcgint;const cgpara : TCGPara);override;
  39. function a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara;override;
  40. function a_call_name_inherited(list : TAsmList;pd : tprocdef;const s : TSymStr; const paras: array of pcgpara): tcgpara;override;
  41. function a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister; const paras: array of pcgpara): tcgpara; override;
  42. procedure a_load_const_reg(list : TAsmList;tosize : tdef;a : tcgint;register : tregister);override;
  43. procedure a_load_const_ref(list : TAsmList;tosize : tdef;a : tcgint;const ref : treference);override;
  44. procedure a_load_reg_ref(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);override;
  45. procedure a_load_reg_reg(list : TAsmList;fromsize, tosize : tdef;reg1,reg2 : tregister);override;
  46. procedure a_load_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);override;
  47. procedure a_load_ref_ref(list : TAsmList;fromsize, tosize : tdef;const sref : treference;const dref : treference);override;
  48. procedure a_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);override;
  49. procedure a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; reg: TRegister); override;
  50. procedure a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister); override;
  51. procedure a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; const ref: TReference); override;
  52. procedure a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); override;
  53. procedure a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); override;
  54. procedure a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); override;
  55. procedure a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); override;
  56. procedure a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation); override;
  57. procedure a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; const ref: treference; l: tasmlabel); override;
  58. procedure a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel); override;
  59. procedure a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel); override;
  60. procedure a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel); override;
  61. procedure a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); override;
  62. procedure a_jmp_always(list : TAsmList;l: tasmlabel); override;
  63. procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override;
  64. procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);override;
  65. procedure a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference); override;
  66. procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); override;
  67. procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); override;
  68. procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); override;
  69. procedure g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean); override;
  70. procedure g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean); override;
  71. procedure gen_load_return_value(list:TAsmList);override;
  72. procedure record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList); override;
  73. procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
  74. procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); override;
  75. procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override;
  76. procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override;
  77. procedure g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); override;
  78. procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation); override;
  79. procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);override;
  80. procedure maybe_change_load_node_reg(list: TAsmList; var n: tnode; reload: boolean); override;
  81. procedure g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); override;
  82. procedure g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); override;
  83. procedure gen_initialize_code(list: TAsmList); override;
  84. procedure gen_entry_code(list: TAsmList); override;
  85. procedure gen_exit_code(list: TAsmList); override;
  86. { unimplemented/unnecessary routines }
  87. procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; srcsize, dstsize: tdef; src, dst: tregister); override;
  88. procedure a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle); override;
  89. procedure a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle); override;
  90. procedure a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle); override;
  91. procedure a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle); override;
  92. procedure a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle); override;
  93. procedure a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle); override;
  94. procedure a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle); override;
  95. procedure g_stackpointer_alloc(list: TAsmList; size: longint); override;
  96. procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint); override;
  97. procedure g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint); override;
  98. procedure g_local_unwind(list: TAsmList; l: TAsmLabel); override;
  99. { JVM-specific routines }
  100. procedure a_load_stack_reg(list : TAsmList;size: tdef;reg: tregister);
  101. { extra_slots are the slots that are used by the reference, and that
  102. will be removed by the store operation }
  103. procedure a_load_stack_ref(list : TAsmList;size: tdef;const ref: treference;extra_slots: longint);
  104. procedure a_load_reg_stack(list : TAsmList;size: tdef;reg: tregister);
  105. { extra_slots are the slots that are used by the reference, and that
  106. will be removed by the load operation }
  107. procedure a_load_ref_stack(list : TAsmList;size: tdef;const ref: treference;extra_slots: longint);
  108. procedure a_load_const_stack(list : TAsmList;size: tdef;a :tcgint; typ: TRegisterType);
  109. procedure a_load_stack_loc(list : TAsmList;size: tdef;const loc: tlocation);
  110. procedure a_load_loc_stack(list : TAsmList;size: tdef;const loc: tlocation);
  111. procedure a_loadfpu_const_stack(list : TAsmList;size: tdef;a :double);
  112. procedure a_op_stack(list : TAsmList;op: topcg; size: tdef; trunc32: boolean);
  113. procedure a_op_const_stack(list : TAsmList;op: topcg; size: tdef;a : tcgint);
  114. procedure a_op_reg_stack(list : TAsmList;op: topcg; size: tdef;reg: tregister);
  115. procedure a_op_ref_stack(list : TAsmList;op: topcg; size: tdef;const ref: treference);
  116. procedure a_op_loc_stack(list : TAsmList;op: topcg; size: tdef;const loc: tlocation);
  117. procedure g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation); override;
  118. { assumes that initdim dimensions have already been pushed on the
  119. evaluation stack, and creates a new array of type arrdef with these
  120. dimensions }
  121. procedure g_newarray(list : TAsmList; arrdef: tdef; initdim: longint);
  122. { gets the length of the array whose reference is stored in arrloc,
  123. and puts it on the evaluation stack }
  124. procedure g_getarraylen(list : TAsmList; const arrloc: tlocation);
  125. { this routine expects that all values are already massaged into the
  126. required form (sign bits xor'ed for gt/lt comparisons for OS_32/OS_64,
  127. see http://stackoverflow.com/questions/4068973/c-performing-signed-comparison-in-unsigned-variables-without-casting ) }
  128. procedure a_cmp_stack_label(list : TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel);
  129. { these 2 routines perform the massaging expected by the previous one }
  130. procedure maybe_adjust_cmp_stackval(list : TAsmlist; size: tdef; cmp_op: topcmp);
  131. function maybe_adjust_cmp_constval(size: tdef; cmp_op: topcmp; a: tcgint): tcgint;
  132. { truncate/sign extend after performing operations on values < 32 bit
  133. that may have overflowed outside the range }
  134. procedure maybe_adjust_op_result(list: TAsmList; op: TOpCg; size: tdef);
  135. { performs sign/zero extension as required }
  136. procedure resize_stack_int_val(list: TAsmList;fromsize,tosize: tdef; formemstore: boolean);
  137. { 8/16 bit unsigned parameters and return values must be sign-extended on
  138. the producer side, because the JVM does not support unsigned variants;
  139. then they have to be zero-extended again on the consumer side }
  140. procedure maybe_resize_stack_para_val(list: TAsmList; retdef: tdef; callside: boolean);
  141. { adjust the stack height after a call based on the specified number of
  142. slots used for parameters and the provided resultdef }
  143. procedure g_adjust_stack_after_call(list: TAsmList; pd: tabstractprocdef; paraheight: longint; forceresdef: tdef);
  144. property maxevalstackheight: longint read fmaxevalstackheight;
  145. procedure gen_initialize_fields_code(list:TAsmList);
  146. procedure gen_typecheck(list: TAsmList; checkop: tasmop; checkdef: tdef);
  147. procedure g_copyvalueparas(p: TObject; arg: pointer); override;
  148. protected
  149. procedure a_load_const_stack_intern(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType; legalize_const: boolean);
  150. function get_enum_init_val_ref(def: tdef; out ref: treference): boolean;
  151. procedure allocate_implicit_structs_for_st_with_base_ref(list: TAsmList; st: tsymtable; const ref: treference; allocvartyp: tsymtyp);
  152. procedure allocate_enum_with_base_ref(list: TAsmList; vs: tabstractvarsym; const initref: treference; destbaseref: treference);
  153. procedure allocate_implicit_struct_with_base_ref(list: TAsmList; vs: tabstractvarsym; ref: treference);
  154. procedure gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara); override;
  155. procedure inittempvariables(list:TAsmList);override;
  156. function g_call_system_proc_intern(list: TAsmList; pd: tprocdef; const paras: array of pcgpara; forceresdef: tdef): tcgpara; override;
  157. { in case of an array, the array base address and index have to be
  158. put on the evaluation stack before the stored value; similarly, for
  159. fields the self pointer has to be loaded first. Also checks whether
  160. the reference is valid. If dup is true, the necessary values are stored
  161. twice. Returns how many stack slots have been consumed, disregarding
  162. the "dup". }
  163. function prepare_stack_for_ref(list: TAsmList; const ref: treference; dup: boolean): longint;
  164. { return the load/store opcode to load/store from/to ref; if the result
  165. has to be and'ed after a load to get the final value, that constant
  166. is returned in finishandval (otherwise that value is set to -1) }
  167. function loadstoreopcref(def: tdef; isload: boolean; const ref: treference; out finishandval: tcgint): tasmop;
  168. { return the load/store opcode to load/store from/to reg; if the result
  169. has to be and'ed after a load to get the final value, that constant
  170. is returned in finishandval (otherwise that value is set to -1) }
  171. function loadstoreopc(def: tdef; isload, isarray: boolean; out finishandval: tcgint): tasmop;
  172. procedure resizestackfpuval(list: TAsmList; fromsize, tosize: tcgsize);
  173. { in case of an OS_32 OP_DIV, we have to use an OS_S64 OP_IDIV because the
  174. JVM does not support unsigned divisions }
  175. procedure maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean);
  176. { common implementation of a_call_* }
  177. function a_call_name_intern(list : TAsmList;pd : tprocdef;const s : TSymStr; forceresdef: tdef; inheritedcall: boolean): tcgpara;
  178. { concatcopy helpers }
  179. procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
  180. procedure concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference);
  181. procedure concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference);
  182. procedure concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference);
  183. end;
  184. const
  185. opcmp2if: array[topcmp] of tasmop = (A_None,
  186. a_ifeq,a_ifgt,a_iflt,a_ifge,a_ifle,
  187. a_ifne,a_ifle,a_iflt,a_ifge,a_ifgt);
  188. implementation
  189. uses
  190. verbose,cutils,globals,fmodule,constexp,
  191. defutil,
  192. aasmtai,aasmcpu,
  193. symtable,symcpu,jvmdef,
  194. procinfo,cpuinfo,cgcpu,tgobj;
  195. const
  196. TOpCG2IAsmOp : array[topcg] of TAsmOp=( { not = xor -1 }
  197. A_None,A_None,a_iadd,a_iand,A_none,a_idiv,a_imul,a_imul,a_ineg,A_None,a_ior,a_ishr,a_ishl,a_iushr,a_isub,a_ixor,A_None,A_None
  198. );
  199. TOpCG2LAsmOp : array[topcg] of TAsmOp=( { not = xor -1 }
  200. A_None,A_None,a_ladd,a_land,A_none,a_ldiv,a_lmul,a_lmul,a_lneg,A_None,a_lor,a_lshr,a_lshl,a_lushr,a_lsub,a_lxor,A_None,A_None
  201. );
  202. constructor thlcgjvm.create;
  203. begin
  204. fevalstackheight:=0;
  205. fmaxevalstackheight:=0;
  206. end;
  207. procedure thlcgjvm.incstack(list: TasmList;slots: longint);
  208. begin
  209. if slots=0 then
  210. exit;
  211. inc(fevalstackheight,slots);
  212. if (fevalstackheight>fmaxevalstackheight) then
  213. fmaxevalstackheight:=fevalstackheight;
  214. if cs_asm_regalloc in current_settings.globalswitches then
  215. list.concat(tai_comment.Create(strpnew(' allocated '+tostr(slots)+', stack height = '+tostr(fevalstackheight))));
  216. end;
  217. procedure thlcgjvm.decstack(list: TAsmList;slots: longint);
  218. begin
  219. if slots=0 then
  220. exit;
  221. dec(fevalstackheight,slots);
  222. if (fevalstackheight<0) and
  223. not(cs_no_regalloc in current_settings.globalswitches) then
  224. internalerror(2010120501);
  225. if cs_asm_regalloc in current_settings.globalswitches then
  226. list.concat(tai_comment.Create(strpnew(' freed '+tostr(slots)+', stack height = '+tostr(fevalstackheight))));
  227. end;
  228. class function thlcgjvm.def2regtyp(def: tdef): tregistertype;
  229. begin
  230. case def.typ of
  231. { records (including files) and enums are implemented via classes }
  232. recorddef,
  233. filedef,
  234. enumdef,
  235. setdef:
  236. result:=R_ADDRESSREGISTER;
  237. { shortstrings are implemented via classes }
  238. else if is_shortstring(def) or
  239. { voiddef can only be typecasted into (implicit) pointers }
  240. is_void(def) then
  241. result:=R_ADDRESSREGISTER
  242. else
  243. result:=inherited;
  244. end;
  245. end;
  246. procedure thlcgjvm.a_load_const_cgpara(list: TAsmList; tosize: tdef; a: tcgint; const cgpara: TCGPara);
  247. begin
  248. tosize:=get_para_push_size(tosize);
  249. if tosize=s8inttype then
  250. a:=shortint(a)
  251. else if tosize=s16inttype then
  252. a:=smallint(a);
  253. inherited a_load_const_cgpara(list, tosize, a, cgpara);
  254. end;
  255. function thlcgjvm.a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara; forceresdef: tdef; weak: boolean): tcgpara;
  256. begin
  257. result:=a_call_name_intern(list,pd,s,forceresdef,false);
  258. end;
  259. function thlcgjvm.a_call_name_inherited(list: TAsmList; pd: tprocdef; const s: TSymStr; const paras: array of pcgpara): tcgpara;
  260. begin
  261. result:=a_call_name_intern(list,pd,s,nil,true);
  262. end;
  263. function thlcgjvm.a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister; const paras: array of pcgpara): tcgpara;
  264. begin
  265. internalerror(2012042824);
  266. result.init;
  267. end;
  268. procedure thlcgjvm.a_load_const_stack_intern(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType; legalize_const: boolean);
  269. begin
  270. if legalize_const and
  271. (typ=R_INTREGISTER) and
  272. (size.typ=orddef) then
  273. begin
  274. { uses specific byte/short array store instructions, and the Dalvik
  275. VM does not like it if we store values outside the range }
  276. case torddef(size).ordtype of
  277. u8bit:
  278. a:=shortint(a);
  279. u16bit:
  280. a:=smallint(a);
  281. else
  282. ;
  283. end;
  284. end;
  285. a_load_const_stack(list,size,a,typ);
  286. end;
  287. procedure thlcgjvm.a_load_const_stack(list : TAsmList;size : tdef;a : tcgint; typ: TRegisterType);
  288. const
  289. int2opc: array[-1..5] of tasmop = (a_iconst_m1,a_iconst_0,a_iconst_1,
  290. a_iconst_2,a_iconst_3,a_iconst_4,a_iconst_5);
  291. begin
  292. case typ of
  293. R_INTREGISTER:
  294. begin
  295. case def_cgsize(size) of
  296. OS_8,OS_16,OS_32,
  297. OS_S8,OS_S16,OS_S32:
  298. begin
  299. { convert cardinals to longints }
  300. a:=longint(a);
  301. if (a>=-1) and
  302. (a<=5) then
  303. list.concat(taicpu.op_none(int2opc[a]))
  304. else if (a>=low(shortint)) and
  305. (a<=high(shortint)) then
  306. list.concat(taicpu.op_const(a_bipush,a))
  307. else if (a>=low(smallint)) and
  308. (a<=high(smallint)) then
  309. list.concat(taicpu.op_const(a_sipush,a))
  310. else
  311. list.concat(taicpu.op_const(a_ldc,a));
  312. { for android verifier }
  313. if (size.typ=orddef) and
  314. (torddef(size).ordtype=uwidechar) then
  315. list.concat(taicpu.op_none(a_i2c));
  316. end;
  317. OS_64,OS_S64:
  318. begin
  319. case a of
  320. 0:
  321. list.concat(taicpu.op_none(a_lconst_0));
  322. 1:
  323. list.concat(taicpu.op_none(a_lconst_1));
  324. else
  325. list.concat(taicpu.op_const(a_ldc2_w,a));
  326. end;
  327. incstack(list,1);
  328. end;
  329. else
  330. internalerror(2010110702);
  331. end;
  332. end;
  333. R_ADDRESSREGISTER:
  334. begin
  335. if a<>0 then
  336. internalerror(2010110701);
  337. list.concat(taicpu.op_none(a_aconst_null));
  338. end;
  339. else
  340. internalerror(2010110703);
  341. end;
  342. incstack(list,1);
  343. end;
  344. procedure thlcgjvm.a_load_stack_loc(list: TAsmList; size: tdef; const loc: tlocation);
  345. begin
  346. case loc.loc of
  347. LOC_REGISTER,LOC_CREGISTER,
  348. LOC_FPUREGISTER,LOC_CFPUREGISTER:
  349. a_load_stack_reg(list,size,loc.register);
  350. LOC_REFERENCE:
  351. a_load_stack_ref(list,size,loc.reference,prepare_stack_for_ref(list,loc.reference,false));
  352. else
  353. internalerror(2011020501);
  354. end;
  355. end;
  356. procedure thlcgjvm.a_load_loc_stack(list: TAsmList;size: tdef;const loc: tlocation);
  357. begin
  358. case loc.loc of
  359. LOC_REGISTER,LOC_CREGISTER,
  360. LOC_FPUREGISTER,LOC_CFPUREGISTER:
  361. a_load_reg_stack(list,size,loc.register);
  362. LOC_REFERENCE,LOC_CREFERENCE:
  363. a_load_ref_stack(list,size,loc.reference,prepare_stack_for_ref(list,loc.reference,false));
  364. LOC_CONSTANT:
  365. a_load_const_stack(list,size,loc.value,def2regtyp(size));
  366. else
  367. internalerror(2011010401);
  368. end;
  369. end;
  370. procedure thlcgjvm.a_loadfpu_const_stack(list: TAsmList; size: tdef; a: double);
  371. begin
  372. case tfloatdef(size).floattype of
  373. s32real:
  374. begin
  375. if a=0.0 then
  376. list.concat(taicpu.op_none(a_fconst_0))
  377. else if a=1.0 then
  378. list.concat(taicpu.op_none(a_fconst_1))
  379. else if a=2.0 then
  380. list.concat(taicpu.op_none(a_fconst_2))
  381. else
  382. list.concat(taicpu.op_single(a_ldc,a));
  383. incstack(list,1);
  384. end;
  385. s64real:
  386. begin
  387. if a=0.0 then
  388. list.concat(taicpu.op_none(a_dconst_0))
  389. else if a=1.0 then
  390. list.concat(taicpu.op_none(a_dconst_1))
  391. else
  392. list.concat(taicpu.op_double(a_ldc2_w,a));
  393. incstack(list,2);
  394. end
  395. else
  396. internalerror(2011010501);
  397. end;
  398. end;
  399. procedure thlcgjvm.a_op_stack(list: TAsmList; op: topcg; size: tdef; trunc32: boolean);
  400. var
  401. cgsize: tcgsize;
  402. begin
  403. if not trunc32 then
  404. cgsize:=def_cgsize(size)
  405. else
  406. begin
  407. resize_stack_int_val(list,u32inttype,s64inttype,false);
  408. cgsize:=OS_S64;
  409. end;
  410. case cgsize of
  411. OS_8,OS_S8,
  412. OS_16,OS_S16,
  413. OS_32,OS_S32:
  414. begin
  415. { not = xor 1 for boolean, xor -1 for the rest}
  416. if op=OP_NOT then
  417. begin
  418. if not is_pasbool(size) then
  419. a_load_const_stack(list,s32inttype,high(cardinal),R_INTREGISTER)
  420. else
  421. a_load_const_stack(list,size,1,R_INTREGISTER);
  422. op:=OP_XOR;
  423. end;
  424. if TOpCG2IAsmOp[op]=A_None then
  425. internalerror(2010120532);
  426. list.concat(taicpu.op_none(TOpCG2IAsmOp[op]));
  427. maybe_adjust_op_result(list,op,size);
  428. if op<>OP_NEG then
  429. decstack(list,1);
  430. end;
  431. OS_64,OS_S64:
  432. begin
  433. { unsigned 64 bit division must be done via a helper }
  434. if op=OP_DIV then
  435. internalerror(2010120530);
  436. { not = xor 1 for boolean, xor -1 for the rest}
  437. if op=OP_NOT then
  438. begin
  439. if not is_pasbool(size) then
  440. a_load_const_stack(list,s64inttype,-1,R_INTREGISTER)
  441. else
  442. a_load_const_stack(list,s64inttype,1,R_INTREGISTER);
  443. op:=OP_XOR;
  444. end;
  445. if TOpCG2LAsmOp[op]=A_None then
  446. internalerror(2010120533);
  447. list.concat(taicpu.op_none(TOpCG2LAsmOp[op]));
  448. case op of
  449. OP_NOT,
  450. OP_NEG:
  451. ;
  452. { the second argument here is an int rather than a long }
  453. OP_SHL,OP_SHR,OP_SAR:
  454. decstack(list,1);
  455. else
  456. decstack(list,2);
  457. end;
  458. end;
  459. else
  460. internalerror(2010120531);
  461. end;
  462. if trunc32 then
  463. begin
  464. list.concat(taicpu.op_none(a_l2i));
  465. decstack(list,1);
  466. end;
  467. end;
  468. procedure thlcgjvm.a_op_const_stack(list: TAsmList;op: topcg;size: tdef;a: tcgint);
  469. var
  470. trunc32: boolean;
  471. begin
  472. maybepreparedivu32(list,op,size,trunc32);
  473. case op of
  474. OP_NEG,OP_NOT:
  475. internalerror(2011010801);
  476. OP_SHL,OP_SHR,OP_SAR:
  477. { the second argument here is an int rather than a long }
  478. a_load_const_stack(list,s32inttype,a,R_INTREGISTER);
  479. else
  480. a_load_const_stack(list,size,a,R_INTREGISTER);
  481. end;
  482. a_op_stack(list,op,size,trunc32);
  483. end;
  484. procedure thlcgjvm.a_op_reg_stack(list: TAsmList; op: topcg; size: tdef; reg: tregister);
  485. var
  486. trunc32: boolean;
  487. begin
  488. maybepreparedivu32(list,op,size,trunc32);
  489. case op of
  490. OP_SHL,OP_SHR,OP_SAR:
  491. if not is_64bitint(size) then
  492. a_load_reg_stack(list,size,reg)
  493. else
  494. begin
  495. { the second argument here is an int rather than a long }
  496. if getsubreg(reg)=R_SUBQ then
  497. internalerror(2011010802);
  498. a_load_reg_stack(list,s32inttype,reg)
  499. end
  500. else
  501. a_load_reg_stack(list,size,reg);
  502. end;
  503. a_op_stack(list,op,size,trunc32);
  504. end;
  505. procedure thlcgjvm.a_op_ref_stack(list: TAsmList; op: topcg; size: tdef; const ref: treference);
  506. var
  507. trunc32: boolean;
  508. begin
  509. { ref must not be the stack top, because that may indicate an error
  510. (it means that we will perform an operation of the stack top onto
  511. itself, so that means the two values have been loaded manually prior
  512. to calling this routine, instead of letting this routine load one of
  513. them; if something like that is needed, call a_op_stack() directly) }
  514. if ref.base=NR_EVAL_STACK_BASE then
  515. internalerror(2010121102);
  516. maybepreparedivu32(list,op,size,trunc32);
  517. case op of
  518. OP_SHL,OP_SHR,OP_SAR:
  519. begin
  520. if not is_64bitint(size) then
  521. a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false))
  522. else
  523. a_load_ref_stack(list,s32inttype,ref,prepare_stack_for_ref(list,ref,false));
  524. end;
  525. else
  526. a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false));
  527. end;
  528. a_op_stack(list,op,size,trunc32);
  529. end;
  530. procedure thlcgjvm.a_op_loc_stack(list: TAsmList; op: topcg; size: tdef; const loc: tlocation);
  531. begin
  532. case loc.loc of
  533. LOC_REGISTER,LOC_CREGISTER:
  534. a_op_reg_stack(list,op,size,loc.register);
  535. LOC_REFERENCE,LOC_CREFERENCE:
  536. a_op_ref_stack(list,op,size,loc.reference);
  537. LOC_CONSTANT:
  538. a_op_const_stack(list,op,size,loc.value);
  539. else
  540. internalerror(2011011415)
  541. end;
  542. end;
  543. procedure thlcgjvm.g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation);
  544. begin
  545. case fromloc.loc of
  546. LOC_CREFERENCE,
  547. LOC_REFERENCE:
  548. begin
  549. toloc:=fromloc;
  550. if (fromloc.reference.base<>NR_NO) and
  551. (fromloc.reference.base<>current_procinfo.framepointer) and
  552. (fromloc.reference.base<>NR_STACK_POINTER_REG) then
  553. g_allocload_reg_reg(list,voidpointertype,fromloc.reference.base,toloc.reference.base,R_ADDRESSREGISTER);
  554. case fromloc.reference.arrayreftype of
  555. art_indexreg:
  556. begin
  557. { all array indices in Java are 32 bit ints }
  558. g_allocload_reg_reg(list,s32inttype,fromloc.reference.index,toloc.reference.index,R_INTREGISTER);
  559. end;
  560. art_indexref:
  561. begin
  562. { base register of the address of the index -> pointer }
  563. if (fromloc.reference.indexbase<>NR_NO) and
  564. (fromloc.reference.indexbase<>NR_STACK_POINTER_REG) then
  565. g_allocload_reg_reg(list,voidpointertype,fromloc.reference.indexbase,toloc.reference.indexbase,R_ADDRESSREGISTER);
  566. end;
  567. else
  568. ;
  569. end;
  570. end;
  571. else
  572. inherited;
  573. end;
  574. end;
  575. procedure thlcgjvm.g_newarray(list: TAsmList; arrdef: tdef; initdim: longint);
  576. var
  577. recref,
  578. enuminitref: treference;
  579. elemdef: tdef;
  580. i: longint;
  581. mangledname: string;
  582. opc: tasmop;
  583. primitivetype: boolean;
  584. begin
  585. elemdef:=arrdef;
  586. if initdim>1 then
  587. begin
  588. { multianewarray typedesc ndim }
  589. list.concat(taicpu.op_sym_const(a_multianewarray,
  590. current_asmdata.RefAsmSymbol(jvmarrtype(elemdef,primitivetype),AT_METADATA),initdim));
  591. { has to be a multi-dimensional array type }
  592. if primitivetype then
  593. internalerror(2011012207);
  594. end
  595. else
  596. begin
  597. { for primitive types:
  598. newarray typedesc
  599. for reference types:
  600. anewarray typedesc
  601. }
  602. { get the type of the elements of the array we are creating }
  603. elemdef:=tarraydef(arrdef).elementdef;
  604. mangledname:=jvmarrtype(elemdef,primitivetype);
  605. if primitivetype then
  606. opc:=a_newarray
  607. else
  608. opc:=a_anewarray;
  609. list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(mangledname,AT_METADATA)));
  610. end;
  611. { all dimensions are removed from the stack, an array reference is
  612. added }
  613. decstack(list,initdim-1);
  614. { in case of an array of records, sets or shortstrings, initialise }
  615. elemdef:=tarraydef(arrdef).elementdef;
  616. for i:=1 to pred(initdim) do
  617. elemdef:=tarraydef(elemdef).elementdef;
  618. if (elemdef.typ in [recorddef,setdef]) or
  619. ((elemdef.typ=enumdef) and
  620. get_enum_init_val_ref(elemdef,enuminitref)) or
  621. is_shortstring(elemdef) or
  622. ((elemdef.typ=procvardef) and
  623. not tprocvardef(elemdef).is_addressonly) or
  624. is_ansistring(elemdef) or
  625. is_wide_or_unicode_string(elemdef) or
  626. is_dynamic_array(elemdef) then
  627. begin
  628. { duplicate array instance }
  629. list.concat(taicpu.op_none(a_dup));
  630. incstack(list,1);
  631. a_load_const_stack(list,s32inttype,initdim-1,R_INTREGISTER);
  632. case elemdef.typ of
  633. arraydef:
  634. g_call_system_proc(list,'fpc_initialize_array_dynarr',[],nil);
  635. recorddef,setdef,procvardef:
  636. begin
  637. tg.gethltemp(list,elemdef,elemdef.size,tt_persistent,recref);
  638. a_load_ref_stack(list,elemdef,recref,prepare_stack_for_ref(list,recref,false));
  639. case elemdef.typ of
  640. recorddef:
  641. g_call_system_proc(list,'fpc_initialize_array_record',[],nil);
  642. setdef:
  643. begin
  644. if tsetdef(elemdef).elementdef.typ=enumdef then
  645. g_call_system_proc(list,'fpc_initialize_array_enumset',[],nil)
  646. else
  647. g_call_system_proc(list,'fpc_initialize_array_bitset',[],nil)
  648. end;
  649. procvardef:
  650. g_call_system_proc(list,'fpc_initialize_array_procvar',[],nil);
  651. else
  652. internalerror(2019051025);
  653. end;
  654. tg.ungettemp(list,recref);
  655. end;
  656. enumdef:
  657. begin
  658. a_load_ref_stack(list,java_jlobject,enuminitref,prepare_stack_for_ref(list,enuminitref,false));
  659. g_call_system_proc(list,'fpc_initialize_array_object',[],nil);
  660. end;
  661. stringdef:
  662. begin
  663. case tstringdef(elemdef).stringtype of
  664. st_shortstring:
  665. begin
  666. a_load_const_stack_intern(list,u8inttype,tstringdef(elemdef).len,R_INTREGISTER,true);
  667. g_call_system_proc(list,'fpc_initialize_array_shortstring',[],nil);
  668. end;
  669. st_ansistring:
  670. g_call_system_proc(list,'fpc_initialize_array_ansistring',[],nil);
  671. st_unicodestring,
  672. st_widestring:
  673. g_call_system_proc(list,'fpc_initialize_array_unicodestring',[],nil);
  674. else
  675. internalerror(2011081801);
  676. end;
  677. end;
  678. else
  679. internalerror(2011081802);
  680. end;
  681. end;
  682. end;
  683. procedure thlcgjvm.g_getarraylen(list: TAsmList; const arrloc: tlocation);
  684. var
  685. nillab,endlab: tasmlabel;
  686. begin
  687. { inline because we have to use the arraylength opcode, which
  688. cannot be represented directly in Pascal. Even though the JVM
  689. supports allocated arrays with length=0, we still also have to
  690. check for nil pointers because even if FPC always generates
  691. allocated empty arrays under all circumstances, external Java
  692. code could pass in nil pointers.
  693. Note that this means that assigned(arr) can be different from
  694. length(arr)<>0 for dynamic arrays when targeting the JVM.
  695. }
  696. current_asmdata.getjumplabel(nillab);
  697. current_asmdata.getjumplabel(endlab);
  698. { if assigned(arr) ... }
  699. a_load_loc_stack(list,java_jlobject,arrloc);
  700. list.concat(taicpu.op_none(a_dup));
  701. incstack(list,1);
  702. list.concat(taicpu.op_sym(a_ifnull,nillab));
  703. decstack(list,1);
  704. { ... then result:=arraylength(arr) ... }
  705. list.concat(taicpu.op_none(a_arraylength));
  706. a_jmp_always(list,endlab);
  707. { ... else result:=0 }
  708. a_label(list,nillab);
  709. list.concat(taicpu.op_none(a_pop));
  710. decstack(list,1);
  711. list.concat(taicpu.op_none(a_iconst_0));
  712. incstack(list,1);
  713. a_label(list,endlab);
  714. end;
  715. procedure thlcgjvm.a_cmp_stack_label(list: TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel);
  716. const
  717. opcmp2icmp: array[topcmp] of tasmop = (A_None,
  718. a_if_icmpeq,a_if_icmpgt,a_if_icmplt,a_if_icmpge,a_if_icmple,
  719. a_if_icmpne,a_if_icmple,a_if_icmplt,a_if_icmpge,a_if_icmpgt);
  720. var
  721. cgsize: tcgsize;
  722. begin
  723. case def2regtyp(size) of
  724. R_INTREGISTER:
  725. begin
  726. cgsize:=def_cgsize(size);
  727. case cgsize of
  728. OS_S8,OS_8,
  729. OS_16,OS_S16,
  730. OS_S32,OS_32:
  731. begin
  732. list.concat(taicpu.op_sym(opcmp2icmp[cmp_op],lab));
  733. decstack(list,2);
  734. end;
  735. OS_64,OS_S64:
  736. begin
  737. list.concat(taicpu.op_none(a_lcmp));
  738. decstack(list,3);
  739. list.concat(taicpu.op_sym(opcmp2if[cmp_op],lab));
  740. decstack(list,1);
  741. end;
  742. else
  743. internalerror(2010120538);
  744. end;
  745. end;
  746. R_ADDRESSREGISTER:
  747. begin
  748. case cmp_op of
  749. OC_EQ:
  750. list.concat(taicpu.op_sym(a_if_acmpeq,lab));
  751. OC_NE:
  752. list.concat(taicpu.op_sym(a_if_acmpne,lab));
  753. else
  754. internalerror(2010120537);
  755. end;
  756. decstack(list,2);
  757. end;
  758. else
  759. internalerror(2010120505);
  760. end;
  761. end;
  762. procedure thlcgjvm.maybe_adjust_cmp_stackval(list: TAsmlist; size: tdef; cmp_op: topcmp);
  763. begin
  764. { use cmp_op because eventually that's what indicates the
  765. signed/unsigned character of the operation, not the size... }
  766. if (cmp_op in [OC_EQ,OC_NE,OC_LT,OC_LTE,OC_GT,OC_GTE]) or
  767. (def2regtyp(size)<>R_INTREGISTER) then
  768. exit;
  769. { http://stackoverflow.com/questions/4068973/c-performing-signed-comparison-in-unsigned-variables-without-casting }
  770. case def_cgsize(size) of
  771. OS_32,OS_S32:
  772. a_op_const_stack(list,OP_XOR,size,cardinal($80000000));
  773. OS_64,OS_S64:
  774. a_op_const_stack(list,OP_XOR,size,tcgint($8000000000000000));
  775. else
  776. ;
  777. end;
  778. end;
  779. function thlcgjvm.maybe_adjust_cmp_constval(size: tdef; cmp_op: topcmp; a: tcgint): tcgint;
  780. begin
  781. result:=a;
  782. { use cmp_op because eventually that's what indicates the
  783. signed/unsigned character of the operation, not the size... }
  784. if (cmp_op in [OC_EQ,OC_NE,OC_LT,OC_LTE,OC_GT,OC_GTE]) or
  785. (def2regtyp(size)<>R_INTREGISTER) then
  786. exit;
  787. case def_cgsize(size) of
  788. OS_32,OS_S32:
  789. result:=a xor cardinal($80000000);
  790. OS_64,OS_S64:
  791. {$push}{$r-}
  792. result:=a xor tcgint($8000000000000000);
  793. {$pop}
  794. else
  795. ;
  796. end;
  797. end;
  798. procedure thlcgjvm.maybe_adjust_op_result(list: TAsmList; op: TOpCg; size: tdef);
  799. const
  800. overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NOT,OP_NEG];
  801. begin
  802. if ((op in overflowops) or
  803. (current_settings.cputype=cpu_dalvik)) and
  804. (def_cgsize(size) in [OS_8,OS_S8,OS_16,OS_S16]) then
  805. resize_stack_int_val(list,s32inttype,size,false);
  806. end;
  807. procedure thlcgjvm.gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara);
  808. begin
  809. { constructors don't return anything in Java }
  810. if pd.proctypeoption=potype_constructor then
  811. exit;
  812. { must return a value of the correct type on the evaluation stack }
  813. case def2regtyp(resdef) of
  814. R_INTREGISTER,
  815. R_ADDRESSREGISTER:
  816. a_load_const_cgpara(list,resdef,0,resloc);
  817. R_FPUREGISTER:
  818. case tfloatdef(resdef).floattype of
  819. s32real:
  820. begin
  821. list.concat(taicpu.op_none(a_fconst_0));
  822. incstack(list,1);
  823. end;
  824. s64real:
  825. begin
  826. list.concat(taicpu.op_none(a_dconst_0));
  827. incstack(list,2);
  828. end;
  829. else
  830. internalerror(2011010302);
  831. end
  832. else
  833. internalerror(2011010301);
  834. end;
  835. end;
  836. procedure thlcgjvm.g_copyvalueparas(p: TObject; arg: pointer);
  837. var
  838. list: tasmlist;
  839. tmpref: treference;
  840. begin
  841. { zero-extend < 32 bit primitive types (FPC can zero-extend when calling,
  842. but that doesn't help when we're called from Java code or indirectly
  843. as a procvar -- exceptions: widechar (Java-specific type) and ordinal
  844. types whose upper bound does not set the sign bit }
  845. if (tsym(p).typ=paravarsym) and
  846. (tparavarsym(p).varspez in [vs_value,vs_const]) and
  847. (tparavarsym(p).vardef.typ=orddef) and
  848. not is_pasbool(tparavarsym(p).vardef) and
  849. not is_widechar(tparavarsym(p).vardef) and
  850. (tparavarsym(p).vardef.size<4) and
  851. not is_signed(tparavarsym(p).vardef) and
  852. (torddef(tparavarsym(p).vardef).high>=(1 shl (tparavarsym(p).vardef.size*8-1))) then
  853. begin
  854. list:=TAsmList(arg);
  855. { store value in new location to keep Android verifier happy }
  856. tg.gethltemp(list,tparavarsym(p).vardef,tparavarsym(p).vardef.size,tt_persistent,tmpref);
  857. a_load_loc_stack(list,tparavarsym(p).vardef,tparavarsym(p).initialloc);
  858. a_op_const_stack(list,OP_AND,tparavarsym(p).vardef,(1 shl (tparavarsym(p).vardef.size*8))-1);
  859. a_load_stack_ref(list,tparavarsym(p).vardef,tmpref,prepare_stack_for_ref(list,tmpref,false));
  860. location_reset_ref(tparavarsym(p).localloc,LOC_REFERENCE,def_cgsize(tparavarsym(p).vardef),4,tmpref.volatility);
  861. tparavarsym(p).localloc.reference:=tmpref;
  862. end;
  863. inherited g_copyvalueparas(p, arg);
  864. end;
  865. procedure thlcgjvm.inittempvariables(list: TAsmList);
  866. begin
  867. { these are automatically initialised when allocated if necessary }
  868. end;
  869. function thlcgjvm.g_call_system_proc_intern(list: TAsmList; pd: tprocdef; const paras: array of pcgpara; forceresdef: tdef): tcgpara;
  870. begin
  871. result:=inherited;
  872. pd.init_paraloc_info(callerside);
  873. g_adjust_stack_after_call(list,pd,pd.callerargareasize,forceresdef);
  874. end;
  875. function thlcgjvm.prepare_stack_for_ref(list: TAsmList; const ref: treference; dup: boolean): longint;
  876. var
  877. href: treference;
  878. begin
  879. result:=0;
  880. { fake location that indicates the value is already on the stack? }
  881. if (ref.base=NR_EVAL_STACK_BASE) then
  882. exit;
  883. if ref.arrayreftype=art_none then
  884. begin
  885. { non-array accesses cannot have an index reg }
  886. if ref.index<>NR_NO then
  887. internalerror(2010120509);
  888. if (ref.base<>NR_NO) then
  889. begin
  890. if (ref.base<>NR_STACK_POINTER_REG) then
  891. begin
  892. { regular field -> load self on the stack }
  893. a_load_reg_stack(list,voidpointertype,ref.base);
  894. if dup then
  895. begin
  896. list.concat(taicpu.op_none(a_dup));
  897. incstack(list,1);
  898. end;
  899. { field name/type encoded in symbol, no index/offset }
  900. if not assigned(ref.symbol) or
  901. (ref.offset<>0) then
  902. internalerror(2010120524);
  903. result:=1;
  904. end
  905. else
  906. begin
  907. { local variable -> offset encoded in opcode and nothing to
  908. do here, except for checking that it's a valid reference }
  909. if assigned(ref.symbol) then
  910. internalerror(2010120523);
  911. end;
  912. end
  913. else
  914. begin
  915. { static field -> nothing to do here, except for validity check }
  916. if not assigned(ref.symbol) or
  917. (ref.offset<>0) then
  918. internalerror(2010120525);
  919. end;
  920. end
  921. else
  922. begin
  923. { arrays have implicit dereference -> pointer to array must have been
  924. loaded into base reg }
  925. if (ref.base=NR_NO) or
  926. (ref.base=NR_STACK_POINTER_REG) then
  927. internalerror(2010120511);
  928. if assigned(ref.symbol) then
  929. internalerror(2010120512);
  930. { stack: ... -> ..., arrayref, index }
  931. { load array base address }
  932. a_load_reg_stack(list,voidpointertype,ref.base);
  933. { index can either be in a register, or located in a simple memory
  934. location (since we have to load it anyway) }
  935. case ref.arrayreftype of
  936. art_indexreg:
  937. begin
  938. if ref.index=NR_NO then
  939. internalerror(2010120513);
  940. { all array indices in Java are 32 bit ints }
  941. a_load_reg_stack(list,s32inttype,ref.index);
  942. end;
  943. art_indexref:
  944. begin
  945. cgutils.reference_reset_base(href,ref.indexbase,ref.indexoffset,ref.temppos,4,ref.volatility);
  946. href.symbol:=ref.indexsymbol;
  947. a_load_ref_stack(list,s32inttype,href,prepare_stack_for_ref(list,href,false));
  948. end;
  949. art_indexconst:
  950. begin
  951. a_load_const_stack(list,s32inttype,ref.indexoffset,R_INTREGISTER);
  952. end;
  953. else
  954. internalerror(2011012001);
  955. end;
  956. { adjustment of the index }
  957. if ref.offset<>0 then
  958. a_op_const_stack(list,OP_ADD,s32inttype,ref.offset);
  959. if dup then
  960. begin
  961. list.concat(taicpu.op_none(a_dup2));
  962. incstack(list,2);
  963. end;
  964. result:=2;
  965. end;
  966. end;
  967. procedure thlcgjvm.a_load_const_reg(list: TAsmList; tosize: tdef; a: tcgint; register: tregister);
  968. begin
  969. a_load_const_stack(list,tosize,a,def2regtyp(tosize));
  970. a_load_stack_reg(list,tosize,register);
  971. end;
  972. procedure thlcgjvm.a_load_const_ref(list: TAsmList; tosize: tdef; a: tcgint; const ref: treference);
  973. var
  974. extra_slots: longint;
  975. begin
  976. extra_slots:=prepare_stack_for_ref(list,ref,false);
  977. a_load_const_stack_intern(list,tosize,a,def2regtyp(tosize),(ref.arrayreftype<>art_none) or assigned(ref.symbol));
  978. a_load_stack_ref(list,tosize,ref,extra_slots);
  979. end;
  980. procedure thlcgjvm.a_load_reg_ref(list: TAsmList; fromsize, tosize: tdef; register: tregister; const ref: treference);
  981. var
  982. extra_slots: longint;
  983. begin
  984. extra_slots:=prepare_stack_for_ref(list,ref,false);
  985. a_load_reg_stack(list,fromsize,register);
  986. if def2regtyp(fromsize)=R_INTREGISTER then
  987. resize_stack_int_val(list,fromsize,tosize,(ref.arrayreftype<>art_none) or assigned(ref.symbol));
  988. a_load_stack_ref(list,tosize,ref,extra_slots);
  989. end;
  990. procedure thlcgjvm.a_load_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister);
  991. begin
  992. a_load_reg_stack(list,fromsize,reg1);
  993. if def2regtyp(fromsize)=R_INTREGISTER then
  994. resize_stack_int_val(list,fromsize,tosize,false);
  995. a_load_stack_reg(list,tosize,reg2);
  996. end;
  997. procedure thlcgjvm.a_load_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; register: tregister);
  998. var
  999. extra_slots: longint;
  1000. begin
  1001. extra_slots:=prepare_stack_for_ref(list,ref,false);
  1002. a_load_ref_stack(list,fromsize,ref,extra_slots);
  1003. if def2regtyp(fromsize)=R_INTREGISTER then
  1004. resize_stack_int_val(list,fromsize,tosize,false);
  1005. a_load_stack_reg(list,tosize,register);
  1006. end;
  1007. procedure thlcgjvm.a_load_ref_ref(list: TAsmList; fromsize, tosize: tdef; const sref: treference; const dref: treference);
  1008. var
  1009. extra_sslots,
  1010. extra_dslots: longint;
  1011. begin
  1012. { make sure the destination reference is on top, since in the end the
  1013. order has to be "destref, value" -> first create "destref, sourceref" }
  1014. extra_dslots:=prepare_stack_for_ref(list,dref,false);
  1015. extra_sslots:=prepare_stack_for_ref(list,sref,false);
  1016. a_load_ref_stack(list,fromsize,sref,extra_sslots);
  1017. if def2regtyp(fromsize)=R_INTREGISTER then
  1018. resize_stack_int_val(list,fromsize,tosize,(dref.arrayreftype<>art_none) or assigned(dref.symbol));
  1019. a_load_stack_ref(list,tosize,dref,extra_dslots);
  1020. end;
  1021. procedure thlcgjvm.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister);
  1022. begin
  1023. { only allowed for types that are not implicit pointers in Pascal (in
  1024. that case, ref contains a pointer to the actual data and we simply
  1025. return that pointer) }
  1026. if not jvmimplicitpointertype(fromsize) then
  1027. internalerror(2010120534);
  1028. a_load_ref_reg(list,java_jlobject,java_jlobject,ref,r);
  1029. end;
  1030. procedure thlcgjvm.a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; reg: TRegister);
  1031. begin
  1032. a_op_const_reg_reg(list,op,size,a,reg,reg);
  1033. end;
  1034. procedure thlcgjvm.a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister);
  1035. begin
  1036. a_load_reg_stack(list,size,src);
  1037. a_op_const_stack(list,op,size,a);
  1038. a_load_stack_reg(list,size,dst);
  1039. end;
  1040. procedure thlcgjvm.a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: tcgint; const ref: TReference);
  1041. var
  1042. extra_slots: longint;
  1043. begin
  1044. extra_slots:=prepare_stack_for_ref(list,ref,true);
  1045. { TODO, here or in peepholeopt: use iinc when possible }
  1046. a_load_ref_stack(list,size,ref,extra_slots);
  1047. a_op_const_stack(list,op,size,a);
  1048. { for android verifier }
  1049. if (def2regtyp(size)=R_INTREGISTER) and
  1050. ((ref.arrayreftype<>art_none) or
  1051. assigned(ref.symbol)) then
  1052. resize_stack_int_val(list,size,size,true);
  1053. a_load_stack_ref(list,size,ref,extra_slots);
  1054. end;
  1055. procedure thlcgjvm.a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister);
  1056. begin
  1057. if not(op in [OP_NOT,OP_NEG]) then
  1058. a_load_reg_stack(list,size,reg);
  1059. a_op_ref_stack(list,op,size,ref);
  1060. a_load_stack_reg(list,size,reg);
  1061. end;
  1062. procedure thlcgjvm.a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister);
  1063. begin
  1064. if not(op in [OP_NOT,OP_NEG]) then
  1065. a_load_reg_stack(list,size,src2);
  1066. a_op_reg_stack(list,op,size,src1);
  1067. a_load_stack_reg(list,size,dst);
  1068. end;
  1069. procedure thlcgjvm.a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister);
  1070. begin
  1071. a_op_reg_reg_reg(list,op,size,reg1,reg2,reg2);
  1072. end;
  1073. procedure thlcgjvm.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: tcgint; src, dst: tregister; setflags: boolean; var ovloc: tlocation);
  1074. var
  1075. tmpreg: tregister;
  1076. begin
  1077. if not setflags then
  1078. begin
  1079. inherited;
  1080. exit;
  1081. end;
  1082. tmpreg:=getintregister(list,size);
  1083. a_load_const_reg(list,size,a,tmpreg);
  1084. a_op_reg_reg_reg_checkoverflow(list,op,size,tmpreg,src,dst,true,ovloc);
  1085. end;
  1086. procedure thlcgjvm.a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister; setflags: boolean; var ovloc: tlocation);
  1087. var
  1088. orgsrc1, orgsrc2: tregister;
  1089. docheck: boolean;
  1090. lab: tasmlabel;
  1091. begin
  1092. if not setflags then
  1093. begin
  1094. inherited;
  1095. exit;
  1096. end;
  1097. { anything else cannot overflow }
  1098. docheck:=size.size in [4,8];
  1099. if docheck then
  1100. begin
  1101. orgsrc1:=src1;
  1102. orgsrc2:=src2;
  1103. if src1=dst then
  1104. begin
  1105. orgsrc1:=getintregister(list,size);
  1106. a_load_reg_reg(list,size,size,src1,orgsrc1);
  1107. end;
  1108. if src2=dst then
  1109. begin
  1110. orgsrc2:=getintregister(list,size);
  1111. a_load_reg_reg(list,size,size,src2,orgsrc2);
  1112. end;
  1113. end;
  1114. a_op_reg_reg_reg(list,op,size,src1,src2,dst);
  1115. if docheck then
  1116. begin
  1117. { * signed overflow for addition iff
  1118. - src1 and src2 are negative and result is positive (excep in case of
  1119. subtraction, then sign of src1 has to be inverted)
  1120. - src1 and src2 are positive and result is negative
  1121. -> Simplified boolean equivalent (in terms of sign bits):
  1122. not(src1 xor src2) and (src1 xor dst)
  1123. for subtraction, multiplication: invert src1 sign bit
  1124. for division: handle separately (div by zero, low(inttype) div -1),
  1125. not supported by this code
  1126. * unsigned overflow iff carry out, aka dst < src1 or dst < src2
  1127. }
  1128. location_reset(ovloc,LOC_REGISTER,OS_S32);
  1129. { not pasbool8, because then we'd still have to convert the integer to
  1130. a boolean via branches for Dalvik}
  1131. ovloc.register:=getintregister(list,s32inttype);
  1132. if not ((size.typ=pointerdef) or
  1133. ((size.typ=orddef) and
  1134. (torddef(size).ordtype in [u64bit,u16bit,u32bit,u8bit,uchar,
  1135. pasbool1,pasbool8,pasbool16,pasbool32,pasbool64]))) then
  1136. begin
  1137. a_load_reg_stack(list,size,src1);
  1138. if op in [OP_SUB,OP_IMUL] then
  1139. a_op_stack(list,OP_NOT,size,false);
  1140. a_op_reg_stack(list,OP_XOR,size,src2);
  1141. a_op_stack(list,OP_NOT,size,false);
  1142. a_load_reg_stack(list,size,src1);
  1143. a_op_reg_stack(list,OP_XOR,size,dst);
  1144. a_op_stack(list,OP_AND,size,false);
  1145. a_op_const_stack(list,OP_SHR,size,(size.size*8)-1);
  1146. if size.size=8 then
  1147. begin
  1148. list.concat(taicpu.op_none(a_l2i));
  1149. decstack(list,1);
  1150. end;
  1151. end
  1152. else
  1153. begin
  1154. a_load_const_stack(list,s32inttype,0,R_INTREGISTER);
  1155. current_asmdata.getjumplabel(lab);
  1156. { can be optimized by removing duplicate xor'ing to convert dst from
  1157. signed to unsigned quadrant }
  1158. a_cmp_reg_reg_label(list,size,OC_B,dst,src1,lab);
  1159. a_cmp_reg_reg_label(list,size,OC_B,dst,src2,lab);
  1160. a_op_const_stack(list,OP_XOR,s32inttype,1);
  1161. a_label(list,lab);
  1162. end;
  1163. a_load_stack_reg(list,s32inttype,ovloc.register);
  1164. end
  1165. else
  1166. ovloc.loc:=LOC_VOID;
  1167. end;
  1168. procedure thlcgjvm.a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; const ref: treference; l: tasmlabel);
  1169. begin
  1170. if ref.base<>NR_EVAL_STACK_BASE then
  1171. a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false));
  1172. maybe_adjust_cmp_stackval(list,size,cmp_op);
  1173. a_load_const_stack(list,size,maybe_adjust_cmp_constval(size,cmp_op,a),def2regtyp(size));
  1174. a_cmp_stack_label(list,size,cmp_op,l);
  1175. end;
  1176. procedure thlcgjvm.a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel);
  1177. begin
  1178. a_load_reg_stack(list,size,reg);
  1179. maybe_adjust_cmp_stackval(list,size,cmp_op);
  1180. a_load_const_stack(list,size,maybe_adjust_cmp_constval(size,cmp_op,a),def2regtyp(size));
  1181. a_cmp_stack_label(list,size,cmp_op,l);
  1182. end;
  1183. procedure thlcgjvm.a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel);
  1184. begin
  1185. a_load_reg_stack(list,size,reg);
  1186. maybe_adjust_cmp_stackval(list,size,cmp_op);
  1187. if ref.base<>NR_EVAL_STACK_BASE then
  1188. a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false))
  1189. else
  1190. list.concat(taicpu.op_none(a_swap));
  1191. maybe_adjust_cmp_stackval(list,size,cmp_op);
  1192. a_cmp_stack_label(list,size,cmp_op,l);
  1193. end;
  1194. procedure thlcgjvm.a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel);
  1195. begin
  1196. if ref.base<>NR_EVAL_STACK_BASE then
  1197. a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false));
  1198. maybe_adjust_cmp_stackval(list,size,cmp_op);
  1199. a_load_reg_stack(list,size,reg);
  1200. maybe_adjust_cmp_stackval(list,size,cmp_op);
  1201. a_cmp_stack_label(list,size,cmp_op,l);
  1202. end;
  1203. procedure thlcgjvm.a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel);
  1204. begin
  1205. a_load_reg_stack(list,size,reg2);
  1206. maybe_adjust_cmp_stackval(list,size,cmp_op);
  1207. a_load_reg_stack(list,size,reg1);
  1208. maybe_adjust_cmp_stackval(list,size,cmp_op);
  1209. a_cmp_stack_label(list,size,cmp_op,l);
  1210. end;
  1211. procedure thlcgjvm.a_jmp_always(list: TAsmList; l: tasmlabel);
  1212. begin
  1213. list.concat(taicpu.op_sym(a_goto,current_asmdata.RefAsmSymbol(l.name,AT_METADATA)));
  1214. end;
  1215. procedure thlcgjvm.concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
  1216. var
  1217. procname: string;
  1218. eledef: tdef;
  1219. ndim: longint;
  1220. adddefaultlenparas: boolean;
  1221. begin
  1222. { load copy helper parameters on the stack }
  1223. a_load_ref_stack(list,java_jlobject,source,prepare_stack_for_ref(list,source,false));
  1224. a_load_ref_stack(list,java_jlobject,dest,prepare_stack_for_ref(list,dest,false));
  1225. { call copy helper }
  1226. eledef:=tarraydef(size).elementdef;
  1227. ndim:=1;
  1228. adddefaultlenparas:=true;
  1229. case eledef.typ of
  1230. orddef:
  1231. begin
  1232. case torddef(eledef).ordtype of
  1233. pasbool1,pasbool8,s8bit,u8bit,bool8bit,uchar,
  1234. s16bit,u16bit,bool16bit,pasbool16,
  1235. uwidechar,
  1236. s32bit,u32bit,bool32bit,pasbool32,
  1237. s64bit,u64bit,bool64bit,pasbool64,scurrency:
  1238. procname:='FPC_COPY_SHALLOW_ARRAY'
  1239. else
  1240. internalerror(2011020504);
  1241. end;
  1242. end;
  1243. arraydef:
  1244. begin
  1245. { call fpc_setlength_dynarr_multidim with deepcopy=true, and extra
  1246. parameters }
  1247. while (eledef.typ=arraydef) and
  1248. not is_dynamic_array(eledef) do
  1249. begin
  1250. eledef:=tarraydef(eledef).elementdef;
  1251. inc(ndim)
  1252. end;
  1253. if (ndim=1) then
  1254. procname:='FPC_COPY_SHALLOW_ARRAY'
  1255. else
  1256. begin
  1257. { deepcopy=true }
  1258. a_load_const_stack(list,pasbool1type,1,R_INTREGISTER);
  1259. { ndim }
  1260. a_load_const_stack(list,s32inttype,ndim,R_INTREGISTER);
  1261. { eletype }
  1262. a_load_const_stack(list,cwidechartype,ord(jvmarrtype_setlength(eledef)),R_INTREGISTER);
  1263. adddefaultlenparas:=false;
  1264. procname:='FPC_SETLENGTH_DYNARR_MULTIDIM';
  1265. end;
  1266. end;
  1267. recorddef:
  1268. procname:='FPC_COPY_JRECORD_ARRAY';
  1269. procvardef:
  1270. if tprocvardef(eledef).is_addressonly then
  1271. procname:='FPC_COPY_SHALLOW_ARRAY'
  1272. else
  1273. procname:='FPC_COPY_JPROCVAR_ARRAY';
  1274. setdef:
  1275. if tsetdef(eledef).elementdef.typ=enumdef then
  1276. procname:='FPC_COPY_JENUMSET_ARRAY'
  1277. else
  1278. procname:='FPC_COPY_JBITSET_ARRAY';
  1279. floatdef:
  1280. procname:='FPC_COPY_SHALLOW_ARRAY';
  1281. stringdef:
  1282. if is_shortstring(eledef) then
  1283. procname:='FPC_COPY_JSHORTSTRING_ARRAY'
  1284. else
  1285. procname:='FPC_COPY_SHALLOW_ARRAY';
  1286. variantdef:
  1287. begin
  1288. {$ifndef nounsupported}
  1289. procname:='FPC_COPY_SHALLOW_ARRAY';
  1290. {$else}
  1291. { todo: make a deep copy via clone... }
  1292. internalerror(2011020505);
  1293. {$endif}
  1294. end;
  1295. else
  1296. procname:='FPC_COPY_SHALLOW_ARRAY';
  1297. end;
  1298. if adddefaultlenparas then
  1299. begin
  1300. { -1, -1 means "copy entire array" }
  1301. a_load_const_stack(list,s32inttype,-1,R_INTREGISTER);
  1302. a_load_const_stack(list,s32inttype,-1,R_INTREGISTER);
  1303. end;
  1304. g_call_system_proc(list,procname,[],nil);
  1305. if ndim<>1 then
  1306. begin
  1307. { pop return value, must be the same as dest }
  1308. list.concat(taicpu.op_none(a_pop));
  1309. decstack(list,1);
  1310. end;
  1311. end;
  1312. procedure thlcgjvm.concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference);
  1313. var
  1314. srsym: tsym;
  1315. pd: tprocdef;
  1316. begin
  1317. { self }
  1318. a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false));
  1319. { result }
  1320. a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false));
  1321. { call fpcDeepCopy helper }
  1322. srsym:=search_struct_member(tabstractrecorddef(size),'FPCDEEPCOPY');
  1323. if not assigned(srsym) or
  1324. (srsym.typ<>procsym) then
  1325. Message1(cg_f_unknown_compilerproc,size.typename+'.fpcDeepCopy');
  1326. pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
  1327. a_call_name(list,pd,pd.mangledname,[],nil,false);
  1328. { both parameters are removed, no function result }
  1329. decstack(list,2);
  1330. end;
  1331. procedure thlcgjvm.concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference);
  1332. begin
  1333. a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false));
  1334. a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false));
  1335. { call set copy helper }
  1336. if tsetdef(size).elementdef.typ=enumdef then
  1337. g_call_system_proc(list,'fpc_enumset_copy',[],nil)
  1338. else
  1339. g_call_system_proc(list,'fpc_bitset_copy',[],nil);
  1340. end;
  1341. procedure thlcgjvm.concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference);
  1342. var
  1343. srsym: tsym;
  1344. pd: tprocdef;
  1345. begin
  1346. { self }
  1347. a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false));
  1348. { result }
  1349. a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false));
  1350. { call fpcDeepCopy helper }
  1351. srsym:=search_struct_member(java_shortstring,'FPCDEEPCOPY');
  1352. if not assigned(srsym) or
  1353. (srsym.typ<>procsym) then
  1354. Message1(cg_f_unknown_compilerproc,'ShortstringClass.FpcDeepCopy');
  1355. pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
  1356. a_call_name(list,pd,pd.mangledname,[],nil,false);
  1357. { both parameters are removed, no function result }
  1358. decstack(list,2);
  1359. end;
  1360. procedure thlcgjvm.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference);
  1361. var
  1362. handled: boolean;
  1363. begin
  1364. handled:=false;
  1365. case size.typ of
  1366. arraydef:
  1367. begin
  1368. if not is_dynamic_array(size) then
  1369. begin
  1370. concatcopy_normal_array(list,size,source,dest);
  1371. handled:=true;
  1372. end;
  1373. end;
  1374. recorddef:
  1375. begin
  1376. concatcopy_record(list,size,source,dest);
  1377. handled:=true;
  1378. end;
  1379. setdef:
  1380. begin
  1381. concatcopy_set(list,size,source,dest);
  1382. handled:=true;
  1383. end;
  1384. stringdef:
  1385. begin
  1386. if is_shortstring(size) then
  1387. begin
  1388. concatcopy_shortstring(list,size,source,dest);
  1389. handled:=true;
  1390. end;
  1391. end;
  1392. procvardef:
  1393. begin
  1394. if not tprocvardef(size).is_addressonly then
  1395. begin
  1396. concatcopy_record(list,tcpuprocvardef(size).classdef,source,dest);
  1397. handled:=true;
  1398. end;
  1399. end;
  1400. else
  1401. ;
  1402. end;
  1403. if not handled then
  1404. inherited;
  1405. end;
  1406. procedure thlcgjvm.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef);
  1407. begin
  1408. concatcopy_shortstring(list,strdef,source,dest);
  1409. end;
  1410. procedure thlcgjvm.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference);
  1411. var
  1412. dstack_slots: longint;
  1413. begin
  1414. dstack_slots:=prepare_stack_for_ref(list,ref2,false);
  1415. a_load_ref_stack(list,fromsize,ref1,prepare_stack_for_ref(list,ref1,false));
  1416. resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize));
  1417. a_load_stack_ref(list,tosize,ref2,dstack_slots);
  1418. end;
  1419. procedure thlcgjvm.a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister);
  1420. begin
  1421. a_load_ref_stack(list,fromsize,ref,prepare_stack_for_ref(list,ref,false));
  1422. resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize));
  1423. a_load_stack_reg(list,tosize,reg);
  1424. end;
  1425. procedure thlcgjvm.a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference);
  1426. var
  1427. dstack_slots: longint;
  1428. begin
  1429. dstack_slots:=prepare_stack_for_ref(list,ref,false);
  1430. a_load_reg_stack(list,fromsize,reg);
  1431. resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize));
  1432. a_load_stack_ref(list,tosize,ref,dstack_slots);
  1433. end;
  1434. procedure thlcgjvm.a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister);
  1435. begin
  1436. a_load_reg_stack(list,fromsize,reg1);
  1437. resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize));
  1438. a_load_stack_reg(list,tosize,reg2);
  1439. end;
  1440. procedure thlcgjvm.g_proc_entry(list: TAsmList; localsize: longint; nostackframe: boolean);
  1441. begin
  1442. { the localsize is based on tg.lasttemp -> already in terms of stack
  1443. slots rather than bytes }
  1444. list.concat(tai_directive.Create(asd_jlimit,'locals '+tostr(localsize)));
  1445. { we insert the unit initialisation code afterwards in the proginit code,
  1446. and it uses one stack slot }
  1447. if (current_procinfo.procdef.proctypeoption=potype_proginit) then
  1448. fmaxevalstackheight:=max(1,fmaxevalstackheight);
  1449. list.concat(tai_directive.Create(asd_jlimit,'stack '+tostr(fmaxevalstackheight)));
  1450. end;
  1451. procedure thlcgjvm.g_proc_exit(list: TAsmList; parasize: longint; nostackframe: boolean);
  1452. var
  1453. retdef: tdef;
  1454. opc: tasmop;
  1455. begin
  1456. if current_procinfo.procdef.proctypeoption in [potype_constructor,potype_class_constructor] then
  1457. retdef:=voidtype
  1458. else
  1459. retdef:=current_procinfo.procdef.returndef;
  1460. case retdef.typ of
  1461. orddef:
  1462. case torddef(retdef).ordtype of
  1463. uvoid:
  1464. opc:=a_return;
  1465. s64bit,
  1466. u64bit,
  1467. scurrency:
  1468. opc:=a_lreturn;
  1469. else
  1470. opc:=a_ireturn;
  1471. end;
  1472. setdef:
  1473. opc:=a_areturn;
  1474. floatdef:
  1475. case tfloatdef(retdef).floattype of
  1476. s32real:
  1477. opc:=a_freturn;
  1478. s64real:
  1479. opc:=a_dreturn;
  1480. else
  1481. internalerror(2011010202);
  1482. end;
  1483. else
  1484. opc:=a_areturn;
  1485. end;
  1486. list.concat(taicpu.op_none(opc));
  1487. end;
  1488. procedure thlcgjvm.gen_load_return_value(list: TAsmList);
  1489. begin
  1490. { constructors don't return anything in the jvm }
  1491. if current_procinfo.procdef.proctypeoption in [potype_constructor,potype_class_constructor] then
  1492. exit;
  1493. inherited gen_load_return_value(list);
  1494. end;
  1495. procedure thlcgjvm.record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList);
  1496. begin
  1497. { add something to the al_procedures list as well, because if all al_*
  1498. lists are empty, the assembler writer isn't called }
  1499. if not code.empty and
  1500. current_asmdata.asmlists[al_procedures].empty then
  1501. current_asmdata.asmlists[al_procedures].concat(tai_align.Create(4));
  1502. tcpuprocdef(pd).exprasmlist:=TAsmList.create;
  1503. tcpuprocdef(pd).exprasmlist.concatlist(code);
  1504. if assigned(data) and
  1505. not data.empty then
  1506. internalerror(2010122801);
  1507. end;
  1508. procedure thlcgjvm.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference);
  1509. begin
  1510. // do nothing
  1511. end;
  1512. procedure thlcgjvm.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
  1513. var
  1514. normaldim: longint;
  1515. eleref: treference;
  1516. begin
  1517. { only in case of initialisation, we have to set all elements to "empty" }
  1518. if name<>'fpc_initialize_array' then
  1519. exit;
  1520. { put array on the stack }
  1521. a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false));
  1522. { in case it's an open array whose elements are regular arrays, put the
  1523. dimension of the regular arrays on the stack (otherwise pass 0) }
  1524. normaldim:=0;
  1525. while (t.typ=arraydef) and
  1526. not is_dynamic_array(t) do
  1527. begin
  1528. inc(normaldim);
  1529. t:=tarraydef(t).elementdef;
  1530. end;
  1531. a_load_const_stack(list,s32inttype,normaldim,R_INTREGISTER);
  1532. { highloc is invalid, the length is part of the array in Java }
  1533. if is_wide_or_unicode_string(t) then
  1534. g_call_system_proc(list,'fpc_initialize_array_unicodestring',[],nil)
  1535. else if is_ansistring(t) then
  1536. g_call_system_proc(list,'fpc_initialize_array_ansistring',[],nil)
  1537. else if is_dynamic_array(t) then
  1538. g_call_system_proc(list,'fpc_initialize_array_dynarr',[],nil)
  1539. else if is_record(t) or
  1540. (t.typ=setdef) then
  1541. begin
  1542. tg.gethltemp(list,t,t.size,tt_persistent,eleref);
  1543. a_load_ref_stack(list,t,eleref,prepare_stack_for_ref(list,eleref,false));
  1544. if is_record(t) then
  1545. g_call_system_proc(list,'fpc_initialize_array_record',[],nil)
  1546. else if tsetdef(t).elementdef.typ=enumdef then
  1547. g_call_system_proc(list,'fpc_initialize_array_enumset',[],nil)
  1548. else
  1549. g_call_system_proc(list,'fpc_initialize_array_bitset',[],nil);
  1550. tg.ungettemp(list,eleref);
  1551. end
  1552. else if (t.typ=enumdef) then
  1553. begin
  1554. if get_enum_init_val_ref(t,eleref) then
  1555. begin
  1556. a_load_ref_stack(list,java_jlobject,eleref,prepare_stack_for_ref(list,eleref,false));
  1557. g_call_system_proc(list,'fpc_initialize_array_object',[],nil);
  1558. end;
  1559. end
  1560. else
  1561. internalerror(2011031901);
  1562. end;
  1563. procedure thlcgjvm.g_initialize(list: TAsmList; t: tdef; const ref: treference);
  1564. var
  1565. dummyloc: tlocation;
  1566. sym: tsym;
  1567. pd: tprocdef;
  1568. begin
  1569. if (t.typ=arraydef) and
  1570. not is_dynamic_array(t) then
  1571. begin
  1572. dummyloc.loc:=LOC_INVALID;
  1573. g_array_rtti_helper(list,tarraydef(t).elementdef,ref,dummyloc,'fpc_initialize_array')
  1574. end
  1575. else if is_record(t) then
  1576. begin
  1577. { call the fpcInitializeRec method }
  1578. sym:=tsym(trecorddef(t).symtable.find('FPCINITIALIZEREC'));
  1579. if assigned(sym) and
  1580. (sym.typ=procsym) then
  1581. begin
  1582. if tprocsym(sym).procdeflist.Count<>1 then
  1583. internalerror(2011071713);
  1584. pd:=tprocdef(tprocsym(sym).procdeflist[0]);
  1585. end
  1586. else
  1587. internalerror(2013113008);
  1588. a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false));
  1589. a_call_name(list,pd,pd.mangledname,[],nil,false);
  1590. { parameter removed, no result }
  1591. decstack(list,1);
  1592. end
  1593. else
  1594. a_load_const_ref(list,t,0,ref);
  1595. end;
  1596. procedure thlcgjvm.g_finalize(list: TAsmList; t: tdef; const ref: treference);
  1597. begin
  1598. // do nothing
  1599. end;
  1600. procedure thlcgjvm.g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef);
  1601. begin
  1602. { not possible, need the original operands }
  1603. internalerror(2012102101);
  1604. end;
  1605. procedure thlcgjvm.g_overflowCheck_loc(List: TAsmList; const Loc: TLocation; def: TDef; var ovloc: tlocation);
  1606. var
  1607. hl : tasmlabel;
  1608. begin
  1609. if not(cs_check_overflow in current_settings.localswitches) then
  1610. exit;
  1611. current_asmdata.getjumplabel(hl);
  1612. a_cmp_const_loc_label(list,s32inttype,OC_EQ,0,ovloc,hl);
  1613. g_call_system_proc(list,'fpc_overflow',[],nil);
  1614. a_label(list,hl);
  1615. end;
  1616. procedure thlcgjvm.location_get_data_ref(list: TAsmList; def: tdef; const l: tlocation; var ref: treference; loadref: boolean; alignment: longint);
  1617. var
  1618. tmploc: tlocation;
  1619. begin
  1620. { This routine is a combination of a generalised a_loadaddr_ref_reg()
  1621. that also works for addresses in registers (in case loadref is false)
  1622. and of a_load_ref_reg (in case loadref is true). It is used for
  1623. a) getting the address of managed var/out parameters
  1624. b) getting to the actual data of value types that are passed by
  1625. reference by the compiler (and then get a local copy at the caller
  1626. side). Normally, depending on whether this reference is passed in a
  1627. register or reference, we either need a reference with that register
  1628. as base or load the address in that reference and use that as a new
  1629. base.
  1630. Since the JVM cannot take the address of anything, all
  1631. "pass-by-reference" value parameters (which are always aggregate types)
  1632. are already simply the implicit pointer to the data (since arrays,
  1633. records, etc are already internally implicit pointers). This means
  1634. that if "loadref" is true, we must simply return this implicit pointer.
  1635. If it is false, we are supposed the take the address of this implicit
  1636. pointer, which is not possible.
  1637. However, managed types are also implicit pointers in Pascal, so in that
  1638. case "taking the address" again consists of simply returning the
  1639. implicit pointer/current value (in case of a var/out parameter, this
  1640. value is stored inside an array).
  1641. }
  1642. if not loadref then
  1643. begin
  1644. if not is_managed_type(def) then
  1645. internalerror(2011020601);
  1646. tmploc:=l;
  1647. end
  1648. else
  1649. begin
  1650. if not jvmimplicitpointertype(def) then
  1651. begin
  1652. { passed by reference in array of single element; l contains the
  1653. base address of the array }
  1654. location_reset_ref(tmploc,LOC_REFERENCE,OS_ADDR,4,ref.volatility);
  1655. cgutils.reference_reset_base(tmploc.reference,getaddressregister(list,java_jlobject),0,tmploc.reference.temppos,4,ref.volatility);
  1656. tmploc.reference.arrayreftype:=art_indexconst;
  1657. tmploc.reference.indexoffset:=0;
  1658. a_load_loc_reg(list,java_jlobject,java_jlobject,l,tmploc.reference.base);
  1659. end
  1660. else
  1661. tmploc:=l;
  1662. end;
  1663. case tmploc.loc of
  1664. LOC_REGISTER,
  1665. LOC_CREGISTER :
  1666. begin
  1667. { the implicit pointer is in a register and has to be in a
  1668. reference -> create a reference and put it there }
  1669. location_force_mem(list,tmploc,java_jlobject);
  1670. ref:=tmploc.reference;
  1671. end;
  1672. LOC_REFERENCE,
  1673. LOC_CREFERENCE :
  1674. begin
  1675. ref:=tmploc.reference;
  1676. end;
  1677. else
  1678. internalerror(2011020603);
  1679. end;
  1680. end;
  1681. procedure thlcgjvm.maybe_change_load_node_reg(list: TAsmList; var n: tnode; reload: boolean);
  1682. begin
  1683. { don't do anything, all registers become stack locations anyway }
  1684. end;
  1685. procedure thlcgjvm.g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister);
  1686. var
  1687. localref: treference;
  1688. arrloc: tlocation;
  1689. stackslots: longint;
  1690. begin
  1691. { temporary reference for passing to concatcopy }
  1692. tg.gethltemp(list,java_jlobject,java_jlobject.size,tt_persistent,localref);
  1693. stackslots:=prepare_stack_for_ref(list,localref,false);
  1694. { create the local copy of the array (lenloc is invalid, get length
  1695. directly from the array) }
  1696. location_reset_ref(arrloc,LOC_REFERENCE,OS_ADDR,sizeof(pint),ref.volatility);
  1697. arrloc.reference:=ref;
  1698. g_getarraylen(list,arrloc);
  1699. g_newarray(list,arrdef,1);
  1700. a_load_stack_ref(list,java_jlobject,localref,stackslots);
  1701. { copy the source array to the destination }
  1702. g_concatcopy(list,arrdef,ref,localref);
  1703. { and put the array pointer in the register as expected by the caller }
  1704. a_load_ref_reg(list,java_jlobject,java_jlobject,localref,destreg);
  1705. end;
  1706. procedure thlcgjvm.g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation);
  1707. begin
  1708. // do nothing, long live garbage collection!
  1709. end;
  1710. procedure thlcgjvm.gen_initialize_code(list: TAsmList);
  1711. var
  1712. ref: treference;
  1713. begin
  1714. { create globals with wrapped types such as arrays/records }
  1715. case current_procinfo.procdef.proctypeoption of
  1716. potype_unitinit:
  1717. begin
  1718. cgutils.reference_reset_base(ref,NR_NO,0,ctempposinvalid,1,[]);
  1719. if assigned(current_module.globalsymtable) then
  1720. allocate_implicit_structs_for_st_with_base_ref(list,current_module.globalsymtable,ref,staticvarsym);
  1721. allocate_implicit_structs_for_st_with_base_ref(list,current_module.localsymtable,ref,staticvarsym);
  1722. end;
  1723. potype_class_constructor:
  1724. begin
  1725. { also initialise local variables, if any }
  1726. inherited;
  1727. { initialise class fields }
  1728. cgutils.reference_reset_base(ref,NR_NO,0,ctempposinvalid,1,[]);
  1729. allocate_implicit_structs_for_st_with_base_ref(list,tabstractrecorddef(current_procinfo.procdef.owner.defowner).symtable,ref,staticvarsym);
  1730. end
  1731. else
  1732. inherited
  1733. end;
  1734. end;
  1735. procedure thlcgjvm.gen_entry_code(list: TAsmList);
  1736. begin
  1737. list.concat(Tai_force_line.Create);
  1738. end;
  1739. procedure thlcgjvm.gen_exit_code(list: TAsmList);
  1740. begin
  1741. { nothing }
  1742. end;
  1743. procedure thlcgjvm.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; srcsize, dstsize: tdef; src, dst: tregister);
  1744. begin
  1745. internalerror(2012090201);
  1746. end;
  1747. procedure thlcgjvm.a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle);
  1748. begin
  1749. internalerror(2012090202);
  1750. end;
  1751. procedure thlcgjvm.a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle);
  1752. begin
  1753. internalerror(2012060130);
  1754. end;
  1755. procedure thlcgjvm.a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle);
  1756. begin
  1757. internalerror(2012060131);
  1758. end;
  1759. procedure thlcgjvm.a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle);
  1760. begin
  1761. internalerror(2012060132);
  1762. end;
  1763. procedure thlcgjvm.a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle);
  1764. begin
  1765. internalerror(2012060133);
  1766. end;
  1767. procedure thlcgjvm.a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle);
  1768. begin
  1769. internalerror(2012060134);
  1770. end;
  1771. procedure thlcgjvm.a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle);
  1772. begin
  1773. internalerror(2012060135);
  1774. end;
  1775. procedure thlcgjvm.g_stackpointer_alloc(list: TAsmList; size: longint);
  1776. begin
  1777. internalerror(2012090203);
  1778. end;
  1779. procedure thlcgjvm.g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);
  1780. begin
  1781. internalerror(2012090204);
  1782. end;
  1783. procedure thlcgjvm.g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint);
  1784. begin
  1785. internalerror(2012090205);
  1786. end;
  1787. procedure thlcgjvm.g_local_unwind(list: TAsmList; l: TAsmLabel);
  1788. begin
  1789. internalerror(2012090206);
  1790. end;
  1791. procedure thlcgjvm.a_load_stack_reg(list: TAsmList; size: tdef; reg: tregister);
  1792. var
  1793. opc: tasmop;
  1794. finishandval: tcgint;
  1795. begin
  1796. opc:=loadstoreopc(size,false,false,finishandval);
  1797. list.concat(taicpu.op_reg(opc,reg));
  1798. { avoid problems with getting the size of an open array etc }
  1799. if jvmimplicitpointertype(size) then
  1800. size:=java_jlobject;
  1801. decstack(list,1+ord(size.size>4));
  1802. end;
  1803. procedure thlcgjvm.a_load_stack_ref(list: TAsmList; size: tdef; const ref: treference; extra_slots: longint);
  1804. var
  1805. opc: tasmop;
  1806. finishandval: tcgint;
  1807. begin
  1808. { fake location that indicates the value has to remain on the stack }
  1809. if ref.base=NR_EVAL_STACK_BASE then
  1810. exit;
  1811. opc:=loadstoreopcref(size,false,ref,finishandval);
  1812. if ref.arrayreftype=art_none then
  1813. list.concat(taicpu.op_ref(opc,ref))
  1814. else
  1815. list.concat(taicpu.op_none(opc));
  1816. { avoid problems with getting the size of an open array etc }
  1817. if jvmimplicitpointertype(size) then
  1818. size:=java_jlobject;
  1819. decstack(list,1+ord(size.size>4)+extra_slots);
  1820. end;
  1821. procedure thlcgjvm.a_load_reg_stack(list: TAsmList; size: tdef; reg: tregister);
  1822. var
  1823. opc: tasmop;
  1824. finishandval: tcgint;
  1825. begin
  1826. opc:=loadstoreopc(size,true,false,finishandval);
  1827. list.concat(taicpu.op_reg(opc,reg));
  1828. { avoid problems with getting the size of an open array etc }
  1829. if jvmimplicitpointertype(size) then
  1830. size:=java_jlobject;
  1831. incstack(list,1+ord(size.size>4));
  1832. if finishandval<>-1 then
  1833. a_op_const_stack(list,OP_AND,size,finishandval);
  1834. end;
  1835. procedure thlcgjvm.a_load_ref_stack(list: TAsmList; size: tdef; const ref: treference; extra_slots: longint);
  1836. var
  1837. opc: tasmop;
  1838. finishandval: tcgint;
  1839. begin
  1840. { fake location that indicates the value is already on the stack? }
  1841. if (ref.base=NR_EVAL_STACK_BASE) then
  1842. exit;
  1843. opc:=loadstoreopcref(size,true,ref,finishandval);
  1844. if ref.arrayreftype=art_none then
  1845. list.concat(taicpu.op_ref(opc,ref))
  1846. else
  1847. list.concat(taicpu.op_none(opc));
  1848. { avoid problems with getting the size of an open array etc }
  1849. if jvmimplicitpointertype(size) then
  1850. size:=java_jlobject;
  1851. incstack(list,1+ord(size.size>4)-extra_slots);
  1852. if finishandval<>-1 then
  1853. a_op_const_stack(list,OP_AND,size,finishandval);
  1854. if ref.checkcast then
  1855. gen_typecheck(list,a_checkcast,size);
  1856. end;
  1857. function thlcgjvm.loadstoreopcref(def: tdef; isload: boolean; const ref: treference; out finishandval: tcgint): tasmop;
  1858. const
  1859. { isload static }
  1860. getputopc: array[boolean,boolean] of tasmop =
  1861. ((a_putfield,a_putstatic),
  1862. (a_getfield,a_getstatic));
  1863. begin
  1864. if assigned(ref.symbol) then
  1865. begin
  1866. { -> either a global (static) field, or a regular field. If a regular
  1867. field, then ref.base contains the self pointer, otherwise
  1868. ref.base=NR_NO. In both cases, the symbol contains all other
  1869. information (combined field name and type descriptor) }
  1870. result:=getputopc[isload,ref.base=NR_NO];
  1871. finishandval:=-1;
  1872. { erase sign extension for byte/smallint loads }
  1873. if (def2regtyp(def)=R_INTREGISTER) and
  1874. not is_signed(def) and
  1875. (def.typ=orddef) and
  1876. not is_widechar(def) then
  1877. case def.size of
  1878. 1: if (torddef(def).high>127) then
  1879. finishandval:=255;
  1880. 2: if (torddef(def).high>32767) then
  1881. finishandval:=65535;
  1882. end;
  1883. end
  1884. else
  1885. result:=loadstoreopc(def,isload,ref.arrayreftype<>art_none,finishandval);
  1886. end;
  1887. function thlcgjvm.loadstoreopc(def: tdef; isload, isarray: boolean; out finishandval: tcgint): tasmop;
  1888. var
  1889. size: longint;
  1890. begin
  1891. finishandval:=-1;
  1892. case def2regtyp(def) of
  1893. R_INTREGISTER:
  1894. begin
  1895. size:=def.size;
  1896. if not isarray then
  1897. begin
  1898. case size of
  1899. 1,2,3,4:
  1900. if isload then
  1901. result:=a_iload
  1902. else
  1903. result:=a_istore;
  1904. 8:
  1905. if isload then
  1906. result:=a_lload
  1907. else
  1908. result:=a_lstore;
  1909. else
  1910. internalerror(2011032814);
  1911. end;
  1912. end
  1913. { array }
  1914. else if isload then
  1915. begin
  1916. case size of
  1917. 1:
  1918. begin
  1919. result:=a_baload;
  1920. if not is_signed(def) and
  1921. (def.typ=orddef) and
  1922. (torddef(def).high>127) then
  1923. finishandval:=255;
  1924. end;
  1925. 2:
  1926. begin
  1927. if is_widechar(def) then
  1928. result:=a_caload
  1929. else
  1930. begin
  1931. result:=a_saload;
  1932. { if we'd treat arrays of word as "array of widechar" we
  1933. could use a_caload, but that would make for even more
  1934. awkward interfacing with external Java code }
  1935. if not is_signed(def) and
  1936. (def.typ=orddef) and
  1937. (torddef(def).high>32767) then
  1938. finishandval:=65535;
  1939. end;
  1940. end;
  1941. 4: result:=a_iaload;
  1942. 8: result:=a_laload;
  1943. else
  1944. internalerror(2010120503);
  1945. end
  1946. end
  1947. else
  1948. begin
  1949. case size of
  1950. 1: result:=a_bastore;
  1951. 2: if not is_widechar(def) then
  1952. result:=a_sastore
  1953. else
  1954. result:=a_castore;
  1955. 4: result:=a_iastore;
  1956. 8: result:=a_lastore;
  1957. else
  1958. internalerror(2010120508);
  1959. end
  1960. end
  1961. end;
  1962. R_ADDRESSREGISTER:
  1963. if not isarray then
  1964. if isload then
  1965. result:=a_aload
  1966. else
  1967. result:=a_astore
  1968. else if isload then
  1969. result:=a_aaload
  1970. else
  1971. result:=a_aastore;
  1972. R_FPUREGISTER:
  1973. begin
  1974. case tfloatdef(def).floattype of
  1975. s32real:
  1976. if not isarray then
  1977. if isload then
  1978. result:=a_fload
  1979. else
  1980. result:=a_fstore
  1981. else if isload then
  1982. result:=a_faload
  1983. else
  1984. result:=a_fastore;
  1985. s64real:
  1986. if not isarray then
  1987. if isload then
  1988. result:=a_dload
  1989. else
  1990. result:=a_dstore
  1991. else if isload then
  1992. result:=a_daload
  1993. else
  1994. result:=a_dastore;
  1995. else
  1996. internalerror(2010120504);
  1997. end
  1998. end
  1999. else
  2000. internalerror(2010120502);
  2001. end;
  2002. end;
  2003. procedure thlcgjvm.resize_stack_int_val(list: TAsmList; fromsize, tosize: tdef; formemstore: boolean);
  2004. var
  2005. fromcgsize, tocgsize: tcgsize;
  2006. begin
  2007. { When storing to an array, field or global variable, make sure the
  2008. static type verification can determine that the stored value fits
  2009. within the boundaries of the declared type (to appease the Dalvik VM).
  2010. Local variables either get their type upgraded in the debug info,
  2011. or have no type information at all }
  2012. if formemstore and
  2013. (tosize.typ=orddef) then
  2014. if (torddef(tosize).ordtype in [u8bit,uchar]) then
  2015. tosize:=s8inttype
  2016. else if torddef(tosize).ordtype=u16bit then
  2017. tosize:=s16inttype;
  2018. fromcgsize:=def_cgsize(fromsize);
  2019. tocgsize:=def_cgsize(tosize);
  2020. if fromcgsize in [OS_S64,OS_64] then
  2021. begin
  2022. if not(tocgsize in [OS_S64,OS_64]) then
  2023. begin
  2024. { truncate }
  2025. list.concat(taicpu.op_none(a_l2i));
  2026. decstack(list,1);
  2027. end;
  2028. end
  2029. else if tocgsize in [OS_S64,OS_64] then
  2030. begin
  2031. { extend }
  2032. list.concat(taicpu.op_none(a_i2l));
  2033. incstack(list,1);
  2034. { if it was an unsigned 32 bit value, remove sign extension }
  2035. if fromcgsize=OS_32 then
  2036. a_op_const_stack(list,OP_AND,s64inttype,cardinal($ffffffff));
  2037. end;
  2038. { Conversions between 32 and 64 bit types have been completely handled
  2039. above. We still may have to truncate or sign extend in case the
  2040. destination type is smaller that the source type, or has a different
  2041. sign. In case the destination is a widechar and the source is not, we
  2042. also have to insert a conversion to widechar.
  2043. In case of Dalvik, we also have to insert conversions for e.g. byte
  2044. -> smallint, because truncating a byte happens via "and 255", and the
  2045. result is a longint in Dalvik's type verification model (so we have
  2046. to "truncate" it back to smallint) }
  2047. if (not(fromcgsize in [OS_S64,OS_64,OS_32,OS_S32]) or
  2048. not(tocgsize in [OS_S64,OS_64,OS_32,OS_S32])) and
  2049. (((current_settings.cputype=cpu_dalvik) and
  2050. not(tocgsize in [OS_32,OS_S32]) and
  2051. not is_signed(fromsize) and
  2052. is_signed(tosize)) or
  2053. (tcgsize2size[fromcgsize]>tcgsize2size[tocgsize]) or
  2054. ((tcgsize2size[fromcgsize]=tcgsize2size[tocgsize]) and
  2055. (fromcgsize<>tocgsize)) or
  2056. { needs to mask out the sign in the top 16 bits }
  2057. ((fromcgsize=OS_S8) and
  2058. (tocgsize=OS_16)) or
  2059. ((tosize=cwidechartype) and
  2060. (fromsize<>cwidechartype))) then
  2061. case tocgsize of
  2062. OS_8:
  2063. a_op_const_stack(list,OP_AND,s32inttype,255);
  2064. OS_S8:
  2065. list.concat(taicpu.op_none(a_i2b));
  2066. OS_16:
  2067. if (tosize.typ=orddef) and
  2068. (torddef(tosize).ordtype=uwidechar) then
  2069. list.concat(taicpu.op_none(a_i2c))
  2070. else
  2071. a_op_const_stack(list,OP_AND,s32inttype,65535);
  2072. OS_S16:
  2073. list.concat(taicpu.op_none(a_i2s));
  2074. else
  2075. ;
  2076. end;
  2077. end;
  2078. procedure thlcgjvm.maybe_resize_stack_para_val(list: TAsmList; retdef: tdef; callside: boolean);
  2079. var
  2080. convsize: tdef;
  2081. begin
  2082. if (retdef.typ=orddef) then
  2083. begin
  2084. if (torddef(retdef).ordtype in [u8bit,u16bit,uchar]) and
  2085. (torddef(retdef).high>=(1 shl (retdef.size*8-1))) then
  2086. begin
  2087. convsize:=nil;
  2088. if callside then
  2089. if torddef(retdef).ordtype in [u8bit,uchar] then
  2090. convsize:=s8inttype
  2091. else
  2092. convsize:=s16inttype
  2093. else if torddef(retdef).ordtype in [u8bit,uchar] then
  2094. convsize:=u8inttype
  2095. else
  2096. convsize:=u16inttype;
  2097. if assigned(convsize) then
  2098. resize_stack_int_val(list,s32inttype,convsize,false);
  2099. end;
  2100. end;
  2101. end;
  2102. procedure thlcgjvm.g_adjust_stack_after_call(list: TAsmList; pd: tabstractprocdef; paraheight: longint; forceresdef: tdef);
  2103. var
  2104. totalremovesize: longint;
  2105. realresdef: tdef;
  2106. begin
  2107. if not assigned(forceresdef) then
  2108. realresdef:=pd.returndef
  2109. else
  2110. realresdef:=forceresdef;
  2111. { a constructor doesn't actually return a value in the jvm }
  2112. if (tabstractprocdef(pd).proctypeoption=potype_constructor) then
  2113. totalremovesize:=paraheight
  2114. else if jvmimplicitpointertype(realresdef) then
  2115. totalremovesize:=paraheight-1
  2116. else if is_void(realresdef) then
  2117. totalremovesize:=paraheight
  2118. else
  2119. { even a byte takes up a full stackslot -> align size to multiple of 4 }
  2120. totalremovesize:=paraheight-(align(realresdef.size,4) shr 2);
  2121. { remove parameters from internal evaluation stack counter (in case of
  2122. e.g. no parameters and a result, it can also increase) }
  2123. if totalremovesize>0 then
  2124. decstack(list,totalremovesize)
  2125. else if totalremovesize<0 then
  2126. incstack(list,-totalremovesize);
  2127. end;
  2128. procedure thlcgjvm.allocate_implicit_struct_with_base_ref(list: TAsmList; vs: tabstractvarsym; ref: treference);
  2129. var
  2130. tmpref: treference;
  2131. begin
  2132. ref.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname,AT_DATA);
  2133. tg.gethltemp(list,vs.vardef,vs.vardef.size,tt_persistent,tmpref);
  2134. { only copy the reference, not the actual data }
  2135. a_load_ref_ref(list,java_jlobject,java_jlobject,tmpref,ref);
  2136. { remains live since there's still a reference to the created
  2137. entity }
  2138. tg.ungettemp(list,tmpref);
  2139. end;
  2140. procedure thlcgjvm.allocate_enum_with_base_ref(list: TAsmList; vs: tabstractvarsym; const initref: treference; destbaseref: treference);
  2141. begin
  2142. destbaseref.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname,AT_DATA);
  2143. { only copy the reference, not the actual data }
  2144. a_load_ref_ref(list,java_jlobject,java_jlobject,initref,destbaseref);
  2145. end;
  2146. function thlcgjvm.get_enum_init_val_ref(def: tdef; out ref: treference): boolean;
  2147. var
  2148. sym: tstaticvarsym;
  2149. begin
  2150. result:=false;
  2151. sym:=tstaticvarsym(tcpuenumdef(tenumdef(def).getbasedef).classdef.symtable.Find('__FPC_ZERO_INITIALIZER'));
  2152. { no enum with ordinal value 0 -> exit }
  2153. if not assigned(sym) then
  2154. exit;
  2155. reference_reset_symbol(ref,current_asmdata.RefAsmSymbol(sym.mangledname,AT_DATA),0,4,[]);
  2156. result:=true;
  2157. end;
  2158. procedure thlcgjvm.allocate_implicit_structs_for_st_with_base_ref(list: TAsmList; st: tsymtable; const ref: treference; allocvartyp: tsymtyp);
  2159. var
  2160. vs: tabstractvarsym;
  2161. def: tdef;
  2162. i: longint;
  2163. initref: treference;
  2164. begin
  2165. for i:=0 to st.symlist.count-1 do
  2166. begin
  2167. if (tsym(st.symlist[i]).typ<>allocvartyp) then
  2168. continue;
  2169. vs:=tabstractvarsym(st.symlist[i]);
  2170. if sp_static in vs.symoptions then
  2171. continue;
  2172. { vo_is_external and vo_has_local_copy means a staticvarsym that is
  2173. alias for a constsym, whose sole purpose is for allocating and
  2174. intialising the constant }
  2175. if [vo_is_external,vo_has_local_copy]*vs.varoptions=[vo_is_external] then
  2176. continue;
  2177. { threadvar innitializations are handled at the node tree level }
  2178. if vo_is_thread_var in vs.varoptions then
  2179. begin
  2180. { nothing }
  2181. end
  2182. else if jvmimplicitpointertype(vs.vardef) then
  2183. allocate_implicit_struct_with_base_ref(list,vs,ref)
  2184. { enums are class instances in Java, while they are ordinals in
  2185. Pascal. When they are initialized with enum(0), such as in
  2186. constructors or global variables, initialize them with the
  2187. enum instance for 0 if it exists (if not, it remains nil since
  2188. there is no valid enum value in it) }
  2189. else if (vs.vardef.typ=enumdef) and
  2190. ((vs.typ<>fieldvarsym) or
  2191. (tdef(vs.owner.defowner).typ<>objectdef) or
  2192. (ts_jvm_enum_field_init in current_settings.targetswitches)) and
  2193. get_enum_init_val_ref(vs.vardef,initref) then
  2194. allocate_enum_with_base_ref(list,vs,initref,ref);
  2195. end;
  2196. { process symtables of routines part of this symtable (for local typed
  2197. constants) }
  2198. if allocvartyp=staticvarsym then
  2199. begin
  2200. for i:=0 to st.deflist.count-1 do
  2201. begin
  2202. def:=tdef(st.deflist[i]);
  2203. { the unit symtable also contains the methods of classes defined
  2204. in that unit -> skip them when processing the unit itself.
  2205. Localst is not assigned for the main program code.
  2206. Localst can be the same as st in case of unit init code. }
  2207. if (def.typ<>procdef) or
  2208. (def.owner<>st) or
  2209. not assigned(tprocdef(def).localst) or
  2210. (tprocdef(def).localst=st) then
  2211. continue;
  2212. allocate_implicit_structs_for_st_with_base_ref(list,tprocdef(def).localst,ref,allocvartyp);
  2213. end;
  2214. end;
  2215. end;
  2216. procedure thlcgjvm.gen_initialize_fields_code(list: TAsmList);
  2217. var
  2218. sym: tsym;
  2219. selfpara: tparavarsym;
  2220. selfreg: tregister;
  2221. ref: treference;
  2222. obj: tabstractrecorddef;
  2223. i: longint;
  2224. needinit: boolean;
  2225. begin
  2226. obj:=tabstractrecorddef(current_procinfo.procdef.owner.defowner);
  2227. { check whether there are any fields that need initialisation }
  2228. needinit:=false;
  2229. for i:=0 to obj.symtable.symlist.count-1 do
  2230. begin
  2231. sym:=tsym(obj.symtable.symlist[i]);
  2232. if (sym.typ=fieldvarsym) and
  2233. not(sp_static in sym.symoptions) and
  2234. (jvmimplicitpointertype(tfieldvarsym(sym).vardef) or
  2235. ((tfieldvarsym(sym).vardef.typ=enumdef) and
  2236. get_enum_init_val_ref(tfieldvarsym(sym).vardef,ref))) then
  2237. begin
  2238. needinit:=true;
  2239. break;
  2240. end;
  2241. end;
  2242. if not needinit then
  2243. exit;
  2244. selfpara:=tparavarsym(current_procinfo.procdef.parast.find('self'));
  2245. if not assigned(selfpara) then
  2246. internalerror(2011033002);
  2247. selfreg:=getaddressregister(list,selfpara.vardef);
  2248. a_load_loc_reg(list,obj,obj,selfpara.localloc,selfreg);
  2249. cgutils.reference_reset_base(ref,selfreg,0,ctempposinvalid,1,[]);
  2250. allocate_implicit_structs_for_st_with_base_ref(list,obj.symtable,ref,fieldvarsym);
  2251. end;
  2252. procedure thlcgjvm.gen_typecheck(list: TAsmList; checkop: tasmop; checkdef: tdef);
  2253. begin
  2254. { replace special types with their equivalent class type }
  2255. if (checkdef.typ=pointerdef) and
  2256. jvmimplicitpointertype(tpointerdef(checkdef).pointeddef) then
  2257. checkdef:=tpointerdef(checkdef).pointeddef;
  2258. if (checkdef=voidpointertype) or
  2259. (checkdef.typ=formaldef) then
  2260. checkdef:=java_jlobject
  2261. else if checkdef.typ=enumdef then
  2262. checkdef:=tcpuenumdef(checkdef).classdef
  2263. else if checkdef.typ=setdef then
  2264. begin
  2265. if tsetdef(checkdef).elementdef.typ=enumdef then
  2266. checkdef:=java_juenumset
  2267. else
  2268. checkdef:=java_jubitset;
  2269. end
  2270. else if checkdef.typ=procvardef then
  2271. checkdef:=tcpuprocvardef(checkdef).classdef
  2272. else if is_wide_or_unicode_string(checkdef) then
  2273. checkdef:=java_jlstring
  2274. else if is_ansistring(checkdef) then
  2275. checkdef:=java_ansistring
  2276. else if is_shortstring(checkdef) then
  2277. checkdef:=java_shortstring;
  2278. if checkdef.typ in [objectdef,recorddef] then
  2279. list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol(tabstractrecorddef(checkdef).jvm_full_typename(true),AT_METADATA)))
  2280. else if checkdef.typ=classrefdef then
  2281. list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol('java/lang/Class',AT_METADATA)))
  2282. else
  2283. list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol(jvmencodetype(checkdef,false),AT_METADATA)));
  2284. end;
  2285. procedure thlcgjvm.resizestackfpuval(list: TAsmList; fromsize, tosize: tcgsize);
  2286. begin
  2287. if (fromsize=OS_F32) and
  2288. (tosize=OS_F64) then
  2289. begin
  2290. list.concat(taicpu.op_none(a_f2d));
  2291. incstack(list,1);
  2292. end
  2293. else if (fromsize=OS_F64) and
  2294. (tosize=OS_F32) then
  2295. begin
  2296. list.concat(taicpu.op_none(a_d2f));
  2297. decstack(list,1);
  2298. end;
  2299. end;
  2300. procedure thlcgjvm.maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean);
  2301. begin
  2302. if (op=OP_DIV) and
  2303. (def_cgsize(size)=OS_32) then
  2304. begin
  2305. { needs zero-extension to 64 bit, because the JVM only supports
  2306. signed divisions }
  2307. resize_stack_int_val(list,u32inttype,s64inttype,false);
  2308. op:=OP_IDIV;
  2309. isdivu32:=true;
  2310. end
  2311. else
  2312. isdivu32:=false;
  2313. end;
  2314. function thlcgjvm.a_call_name_intern(list: TAsmList; pd: tprocdef; const s: TSymStr; forceresdef: tdef; inheritedcall: boolean): tcgpara;
  2315. var
  2316. opc: tasmop;
  2317. begin
  2318. {
  2319. invoke types:
  2320. * invokeinterface: call method from an interface (must also specify
  2321. number of parameters in terms of stack slot count!)
  2322. * invokespecial: invoke a constructor, method in a superclass,
  2323. or private instance method
  2324. * invokestatic: invoke a class method (private or not)
  2325. * invokevirtual: invoke a regular method
  2326. }
  2327. case pd.owner.symtabletype of
  2328. globalsymtable,
  2329. staticsymtable,
  2330. localsymtable:
  2331. { regular and nested procedures are turned into static methods }
  2332. opc:=a_invokestatic;
  2333. objectsymtable:
  2334. begin
  2335. case tobjectdef(pd.owner.defowner).objecttype of
  2336. odt_javaclass:
  2337. begin
  2338. if (po_classmethod in pd.procoptions) or
  2339. (pd.proctypeoption=potype_operator) then
  2340. opc:=a_invokestatic
  2341. else if (pd.visibility=vis_strictprivate) or
  2342. (pd.proctypeoption=potype_constructor) or
  2343. inheritedcall then
  2344. opc:=a_invokespecial
  2345. else
  2346. opc:=a_invokevirtual;
  2347. end;
  2348. odt_interfacejava:
  2349. { static interface methods are not allowed }
  2350. opc:=a_invokeinterface;
  2351. else
  2352. internalerror(2010122601);
  2353. end;
  2354. end;
  2355. recordsymtable:
  2356. begin
  2357. if (po_staticmethod in pd.procoptions) or
  2358. (pd.proctypeoption=potype_operator) then
  2359. opc:=a_invokestatic
  2360. else if (pd.visibility=vis_strictprivate) or
  2361. (pd.proctypeoption=potype_constructor) or
  2362. inheritedcall then
  2363. opc:=a_invokespecial
  2364. else
  2365. opc:=a_invokevirtual;
  2366. end
  2367. else
  2368. internalerror(2010122602);
  2369. end;
  2370. if (opc<>a_invokeinterface) then
  2371. list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(s,AT_FUNCTION)))
  2372. else
  2373. begin
  2374. pd.init_paraloc_info(calleeside);
  2375. list.concat(taicpu.op_sym_const(opc,current_asmdata.RefAsmSymbol(s,AT_FUNCTION),pd.calleeargareasize));
  2376. end;
  2377. result:=get_call_result_cgpara(pd,forceresdef);
  2378. end;
  2379. procedure create_hlcodegen_cpu;
  2380. begin
  2381. hlcg:=thlcgjvm.create;
  2382. create_codegen;
  2383. end;
  2384. begin
  2385. chlcgobj:=thlcgjvm;
  2386. create_hlcodegen:=@create_hlcodegen_cpu;
  2387. end.