genhl.ml 132 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329
  1. (*
  2. * Copyright (C)2005-2015 Haxe Foundation
  3. *
  4. * Permission is hereby granted, free of charge, to any person obtaining a
  5. * copy of this software and associated documentation files (the "Software"),
  6. * to deal in the Software without restriction, including without limitation
  7. * the rights to use, copy, modify, merge, publish, distribute, sublicense,
  8. * and/or sell copies of the Software, and to permit persons to whom the
  9. * Software is furnished to do so, subject to the following conditions:
  10. *
  11. * The above copyright notice and this permission notice shall be included in
  12. * all copies or substantial portions of the Software.
  13. *
  14. * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  15. * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  16. * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  17. * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  18. * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  19. * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  20. * DEALINGS IN THE SOFTWARE.
  21. *)
  22. open Extlib_leftovers
  23. open Globals
  24. open Ast
  25. open Type
  26. open Error
  27. open Common
  28. open Hlcode
  29. (* compiler *)
  30. type ('a,'b) lookup = {
  31. arr : 'b DynArray.t;
  32. mutable map : ('a, int) PMap.t;
  33. }
  34. (* not mutable, might be be shared *)
  35. type method_capture = {
  36. c_map : (int, int) PMap.t;
  37. c_vars : tvar array;
  38. c_type : ttype;
  39. c_group : bool;
  40. }
  41. type allocator = {
  42. mutable a_all : int list;
  43. mutable a_hold : int list;
  44. }
  45. type lassign = (string index * int)
  46. type method_context = {
  47. mid : int;
  48. mregs : (int, ttype) lookup;
  49. mops : opcode DynArray.t;
  50. mret : ttype;
  51. mdebug : Globals.pos DynArray.t;
  52. mvars : (int, int) Hashtbl.t;
  53. mhasthis : bool;
  54. mutable mdeclared : int list;
  55. mutable mallocs : (ttype, allocator) PMap.t;
  56. mutable mcaptured : method_capture;
  57. mutable mcontinues : (int -> unit) list;
  58. mutable mbreaks : (int -> unit) list;
  59. mutable mtrys : int;
  60. mutable mloop_trys : int;
  61. mutable mcaptreg : int;
  62. mutable mcurpos : Globals.pos;
  63. mutable massign : lassign list;
  64. }
  65. type array_impl = {
  66. aall : tclass;
  67. abase : tclass;
  68. adyn : tclass;
  69. aobj : tclass;
  70. aui16 : tclass;
  71. ai32 : tclass;
  72. af32 : tclass;
  73. af64 : tclass;
  74. ai64 : tclass;
  75. }
  76. type constval =
  77. | CString of string
  78. type context = {
  79. com : Common.context;
  80. cglobals : (string, ttype) lookup;
  81. cstrings : (string, string) lookup;
  82. cbytes : (bytes, bytes) lookup;
  83. cfloats : (float, float) lookup;
  84. cints : (int32, int32) lookup;
  85. cnatives : (string * int, (string index * string index * ttype * functable index)) lookup;
  86. cfids : (string * path, unit) lookup;
  87. cfunctions : fundecl DynArray.t;
  88. cconstants : (constval, (global * int array)) lookup;
  89. optimize : bool;
  90. w_null_compare : bool;
  91. overrides : (string * path, bool) Hashtbl.t;
  92. defined_funs : (int,unit) Hashtbl.t;
  93. mutable dump_out : (unit IO.output) option;
  94. mutable cached_types : (string list, ttype) PMap.t;
  95. mutable m : method_context;
  96. mutable anons_cache : (tanon, ttype) PMap.t;
  97. mutable method_wrappers : ((ttype * ttype), int) PMap.t;
  98. mutable rec_cache : (Type.t * ttype option ref) list;
  99. mutable cached_tuples : (ttype list, ttype) PMap.t;
  100. mutable tstring : ttype;
  101. macro_typedefs : (string, ttype) Hashtbl.t;
  102. array_impl : array_impl;
  103. base_class : tclass;
  104. base_type : tclass;
  105. base_enum : tclass;
  106. core_type : tclass;
  107. core_enum : tclass;
  108. ref_abstract : tabstract;
  109. cdebug_files : (string, string) lookup;
  110. mutable ct_delayed : (unit -> unit) list;
  111. mutable ct_depth : int;
  112. }
  113. (* --- *)
  114. type access =
  115. | ANone
  116. | AGlobal of global
  117. | ALocal of tvar * reg
  118. | AStaticVar of global * ttype * field index
  119. | AStaticFun of fundecl index
  120. | AInstanceFun of texpr * fundecl index
  121. | AInstanceProto of texpr * field index
  122. | AInstanceField of texpr * field index
  123. | AArray of reg * (ttype * ttype) * reg
  124. | ACArray of reg * ttype * reg
  125. | AVirtualMethod of texpr * field index
  126. | ADynamic of texpr * string index
  127. | AEnum of tenum * field index
  128. | ACaptured of field index
  129. let is_to_string t =
  130. match follow t with
  131. | TFun([],r) -> (match follow r with TInst({ cl_path=[],"String" },[]) -> true | _ -> false)
  132. | _ -> false
  133. let is_string = function
  134. | HObj { pname = "String"} -> true
  135. | _ -> false
  136. let is_extern_field f =
  137. not (Type.is_physical_field f) || (match f.cf_kind with Method MethNormal -> List.exists (fun (m,_,_) -> m = Meta.HlNative) f.cf_meta | _ -> false) || has_class_field_flag f CfExtern
  138. let is_array_class name =
  139. match name with
  140. | "hl.types.ArrayDyn" | "hl.types.ArrayBytes_Int" | "hl.types.ArrayBytes_Float" | "hl.types.ArrayObj" | "hl.types.ArrayBytes_hl_F32" | "hl.types.ArrayBytes_hl_UI16" | "hl.types.ArrayBytes_hl_I64" -> true
  141. | _ -> false
  142. let is_array_type t =
  143. match t with
  144. | HObj p -> is_array_class p.pname
  145. | _ -> false
  146. let max_pos e =
  147. let p = e.epos in
  148. { p with pmin = p.pmax }
  149. let to_utf8 str p =
  150. let u8 = try
  151. UTF8.validate str;
  152. str;
  153. with
  154. UTF8.Malformed_code ->
  155. (* ISO to utf8 *)
  156. let b = UTF8.Buf.create 0 in
  157. String.iter (fun c -> UTF8.Buf.add_char b (UCharExt.of_char c)) str;
  158. UTF8.Buf.contents b
  159. in
  160. let ccount = ref 0 in
  161. UTF8.iter (fun c ->
  162. let c = UCharExt.code c in
  163. if (c >= 0xD800 && c <= 0xDFFF) || c >= 0x110000 then abort "Invalid unicode char" p;
  164. incr ccount;
  165. if c >= 0x10000 then incr ccount;
  166. ) u8;
  167. u8, !ccount
  168. let tuple_type ctx tl =
  169. try
  170. PMap.find tl ctx.cached_tuples
  171. with Not_found ->
  172. let ct = HEnum {
  173. eglobal = None;
  174. ename = "";
  175. eid = 0;
  176. efields = [|"",0,Array.of_list tl|];
  177. } in
  178. ctx.cached_tuples <- PMap.add tl ct ctx.cached_tuples;
  179. ct
  180. let type_size_bits = function
  181. | HUI8 | HBool -> 0
  182. | HUI16 -> 1
  183. | HI32 | HF32 -> 2
  184. | HI64 | HF64 -> 3
  185. | _ -> die "" __LOC__
  186. let new_lookup() =
  187. {
  188. arr = DynArray.create();
  189. map = PMap.empty;
  190. }
  191. let null_capture =
  192. {
  193. c_vars = [||];
  194. c_map = PMap.empty;
  195. c_type = HVoid;
  196. c_group = false;
  197. }
  198. let lookup l v fb =
  199. try
  200. PMap.find v l.map
  201. with Not_found ->
  202. let id = DynArray.length l.arr in
  203. DynArray.add l.arr (Obj.magic 0);
  204. l.map <- PMap.add v id l.map;
  205. DynArray.set l.arr id (fb());
  206. id
  207. let lookup_alloc l v =
  208. let id = DynArray.length l.arr in
  209. DynArray.add l.arr v;
  210. id
  211. let method_context id t captured hasthis =
  212. {
  213. mid = id;
  214. mregs = new_lookup();
  215. mops = DynArray.create();
  216. mvars = Hashtbl.create 0;
  217. mallocs = PMap.empty;
  218. mret = t;
  219. mbreaks = [];
  220. mdeclared = [];
  221. mcontinues = [];
  222. mhasthis = hasthis;
  223. mcaptured = captured;
  224. mtrys = 0;
  225. mloop_trys = 0;
  226. mcaptreg = 0;
  227. mdebug = DynArray.create();
  228. mcurpos = Globals.null_pos;
  229. massign = [];
  230. }
  231. let field_name c f =
  232. s_type_path c.cl_path ^ ":" ^ f.cf_name
  233. let efield_name e f =
  234. s_type_path e.e_path ^ ":" ^ f.ef_name
  235. let global_type ctx g =
  236. DynArray.get ctx.cglobals.arr g
  237. let is_overridden ctx c f =
  238. Hashtbl.mem ctx.overrides (f.cf_name,c.cl_path)
  239. let alloc_float ctx f =
  240. lookup ctx.cfloats f (fun() -> f)
  241. let alloc_i32 ctx i =
  242. lookup ctx.cints i (fun() -> i)
  243. let alloc_string ctx s =
  244. lookup ctx.cstrings s (fun() -> s)
  245. let alloc_bytes ctx s =
  246. lookup ctx.cbytes s (fun() -> s)
  247. let array_class ctx t =
  248. match t with
  249. | HI32 ->
  250. ctx.array_impl.ai32
  251. | HUI16 ->
  252. ctx.array_impl.aui16
  253. | HF32 ->
  254. ctx.array_impl.af32
  255. | HF64 ->
  256. ctx.array_impl.af64
  257. | HI64 ->
  258. ctx.array_impl.ai64
  259. | HDyn ->
  260. ctx.array_impl.adyn
  261. | _ ->
  262. ctx.array_impl.aobj
  263. let member_fun c t =
  264. match follow t with
  265. | TFun (args, ret) -> TFun (("this",false,TInst(c,[])) :: args, ret)
  266. | _ -> die "" __LOC__
  267. let rec unsigned t =
  268. match follow t with
  269. | TAbstract ({ a_path = [],"UInt" },_) -> true
  270. | TAbstract (a,pl) -> unsigned (Abstract.get_underlying_type a pl)
  271. | _ -> false
  272. let unsigned_op e1 e2 =
  273. let is_unsigned e =
  274. match e.eexpr with
  275. | TConst (TInt _) -> true
  276. | _ -> unsigned e.etype
  277. in
  278. is_unsigned e1 && is_unsigned e2
  279. let rec get_const e =
  280. match e.eexpr with
  281. | TConst c -> c
  282. | TParenthesis e | TCast (e,_) -> get_const e
  283. | _ -> abort "Should be a constant" e.epos
  284. let set_curpos ctx p =
  285. ctx.m.mcurpos <- p
  286. let make_debug ctx arr =
  287. let get_relative_path p =
  288. match Common.defined ctx.com Common.Define.AbsolutePath with
  289. | true -> if (Filename.is_relative p.pfile)
  290. then Filename.concat (Sys.getcwd()) p.pfile
  291. else p.pfile
  292. | false -> try
  293. (* lookup relative path *)
  294. let len = String.length p.pfile in
  295. let base = ctx.com.class_paths#find (fun path ->
  296. let path = path#path in
  297. let l = String.length path in
  298. len > l && String.sub p.pfile 0 l = path
  299. ) in
  300. let l = String.length base#path in
  301. String.sub p.pfile l (len - l)
  302. with Not_found ->
  303. p.pfile
  304. in
  305. let pos = ref (0,0,Globals.null_pos) in
  306. let cur_file = ref 0 in
  307. let cur_line = ref 0 in
  308. let cur = ref Globals.null_pos in
  309. let out = Array.make (DynArray.length arr) !pos in
  310. for i = 0 to DynArray.length arr - 1 do
  311. let p = DynArray.unsafe_get arr i in
  312. if p != !cur then begin
  313. let file = if p.pfile == (!cur).pfile then !cur_file else lookup ctx.cdebug_files p.pfile (fun() -> get_relative_path p) in
  314. let line = Lexer.get_error_line p in
  315. if line <> !cur_line || file <> !cur_file then begin
  316. cur_file := file;
  317. cur_line := line;
  318. pos := (file,line,p);
  319. end;
  320. cur := p;
  321. end;
  322. Array.unsafe_set out i !pos
  323. done;
  324. out
  325. let fake_tnull =
  326. {null_abstract with
  327. a_path = [],"Null";
  328. a_params = [mk_type_param null_class TPHType None None];
  329. }
  330. let get_rec_cache ctx t none_callback not_found_callback =
  331. try
  332. match !(List.assq t ctx.rec_cache) with
  333. | None -> none_callback()
  334. | Some t -> t
  335. with Not_found ->
  336. let tref = ref None in
  337. ctx.rec_cache <- (t,tref) :: ctx.rec_cache;
  338. let t = not_found_callback tref in
  339. ctx.rec_cache <- List.tl ctx.rec_cache;
  340. t
  341. let rec to_type ?tref ctx t =
  342. match t with
  343. | TMono r ->
  344. (match r.tm_type with
  345. | None -> HDyn
  346. | Some t -> to_type ?tref ctx t)
  347. | TType (td,tl) ->
  348. let t =
  349. get_rec_cache ctx t
  350. (fun() -> abort "Unsupported recursive type" td.t_pos)
  351. (fun tref -> to_type ~tref ctx (apply_typedef td tl))
  352. in
  353. (match td.t_path with
  354. | ["haxe";"macro"], name -> Hashtbl.replace ctx.macro_typedefs name t; t
  355. | _ -> t)
  356. | TLazy f ->
  357. to_type ?tref ctx (lazy_type f)
  358. | TFun (args, ret) ->
  359. HFun (List.map (fun (_,o,t) ->
  360. let pt = to_type ctx t in
  361. if o && not (is_nullable pt) then HRef pt else pt
  362. ) args, to_type ctx ret)
  363. | TAnon a when (match !(a.a_status) with ClassStatics _ | EnumStatics _ -> true | _ -> false) ->
  364. (match !(a.a_status) with
  365. | ClassStatics c ->
  366. class_type ctx c (extract_param_types c.cl_params) true
  367. | EnumStatics e ->
  368. enum_class ctx e
  369. | _ -> die "" __LOC__)
  370. | TAnon a ->
  371. if PMap.is_empty a.a_fields then HDyn else
  372. (try
  373. (* can't use physical comparison in PMap since addresses might change in GC compact,
  374. maybe add an uid to tanon if too slow ? *)
  375. PMap.find a ctx.anons_cache
  376. with Not_found ->
  377. let vp = {
  378. vfields = [||];
  379. vindex = PMap.empty;
  380. } in
  381. let t = HVirtual vp in
  382. (match tref with
  383. | None -> ()
  384. | Some r -> r := Some t);
  385. ctx.anons_cache <- PMap.add a t ctx.anons_cache;
  386. let fields = PMap.fold (fun cf acc -> cfield_type ctx cf :: acc) a.a_fields [] in
  387. let fields = List.sort (fun (n1,_,_) (n2,_,_) -> compare n1 n2) fields in
  388. vp.vfields <- Array.of_list fields;
  389. Array.iteri (fun i (n,_,_) -> vp.vindex <- PMap.add n i vp.vindex) vp.vfields;
  390. t
  391. )
  392. | TDynamic _ ->
  393. HDyn
  394. | TEnum (e,_) ->
  395. enum_type ~tref ctx e
  396. | TInst ({ cl_path = ["hl"],"Abstract" },[TInst({ cl_kind = KExpr (EConst (String(name,_)),_) },_)]) ->
  397. HAbstract (name, alloc_string ctx name)
  398. | TInst (c,pl) ->
  399. (match c.cl_kind with
  400. | KTypeParameter ttp ->
  401. let rec loop = function
  402. | [] -> HDyn
  403. | t :: tl ->
  404. match follow (apply_params c.cl_params pl t) with
  405. | TInst (c,_) as t when not (has_class_flag c CInterface) -> to_type ?tref ctx t
  406. | _ -> loop tl
  407. in
  408. loop (get_constraints ttp)
  409. | _ -> class_type ~tref ctx c pl false)
  410. | TAbstract ({a_path = [],"Null"},[t1]) ->
  411. let t = to_type ?tref ctx t1 in
  412. if not (is_nullable t) && t <> HVoid then HNull t else t
  413. | TAbstract (a,pl) ->
  414. if Meta.has Meta.CoreType a.a_meta then
  415. (match a.a_path with
  416. | [], "Void" -> HVoid
  417. | [], "Int" | [], "UInt" -> HI32
  418. | [], "Float" -> HF64
  419. | [], "Single" -> HF32
  420. | [], "Bool" -> HBool
  421. | [], "Dynamic" -> HDyn
  422. | [], "Class" ->
  423. class_type ctx ctx.base_class [] false
  424. | [], "Enum" ->
  425. class_type ctx ctx.base_type [] false
  426. | [], "EnumValue" -> HDyn
  427. | ["hl"], "Ref" -> HRef (to_type ctx (List.hd pl))
  428. | ["hl"], ("Bytes" | "BytesAccess") -> HBytes
  429. | ["hl"], "Type" -> HType
  430. | ["hl"], "UI16" -> HUI16
  431. | ["hl"], "UI8" -> HUI8
  432. | ["hl"], "I64" -> HI64
  433. | ["hl"], "NativeArray" -> HArray (to_type ctx (List.hd pl))
  434. | ["haxe";"macro"], "Position" -> HAbstract ("macro_pos", alloc_string ctx "macro_pos")
  435. | _ -> failwith ("Unknown core type " ^ s_type_path a.a_path))
  436. else
  437. get_rec_cache ctx t
  438. (fun() -> HDyn)
  439. (fun tref -> to_type ~tref ctx (Abstract.get_underlying_type a pl))
  440. and resolve_class ctx c pl statics =
  441. let not_supported() =
  442. failwith ("Extern type not supported : " ^ s_type (print_context()) (TInst (c,pl)))
  443. in
  444. match c.cl_path, pl with
  445. | ([],"Array"), [t] ->
  446. if statics then ctx.array_impl.abase else array_class ctx (to_type ctx t)
  447. | ([],"Array"), [] ->
  448. die "" __LOC__
  449. | _, _ when (has_class_flag c CExtern) ->
  450. not_supported()
  451. | _ ->
  452. c
  453. and cfield_type ctx cf =
  454. let t = to_type ctx cf.cf_type in
  455. let t = (match cf.cf_kind, t with
  456. | Method (MethNormal|MethInline), HFun (args,ret) -> HMethod (args,ret)
  457. | _ -> t
  458. ) in
  459. (cf.cf_name,alloc_string ctx cf.cf_name,t)
  460. and field_type ctx f p =
  461. match f with
  462. | FInstance (c,pl,f) | FClosure (Some (c,pl),f) ->
  463. let creal = resolve_class ctx c pl false in
  464. let rec loop c =
  465. try
  466. PMap.find f.cf_name c.cl_fields
  467. with Not_found ->
  468. match c.cl_super with
  469. | Some (csup,_) -> loop csup
  470. | None -> abort (s_type_path creal.cl_path ^ " is missing field " ^ f.cf_name) p
  471. in
  472. (loop creal).cf_type
  473. | FStatic (_,f) | FAnon f | FClosure (_,f) -> f.cf_type
  474. | FDynamic _ -> t_dynamic
  475. | FEnum (_,f) -> f.ef_type
  476. and real_type ctx e =
  477. let rec loop e =
  478. match e.eexpr with
  479. | TField (_,f) ->
  480. let ft = field_type ctx f e.epos in
  481. (match ft, e.etype with
  482. | TFun (args,ret), TFun (args2,_) ->
  483. TFun (List.map2 (fun ((name,opt,t) as a) ((_,_,t2) as a2) ->
  484. match t, t2 with
  485. (*
  486. Handle function variance:
  487. If we have type parameters which are function types, we need to keep the functions
  488. because we might need to insert a cast to coerce Void->Bool to Void->Dynamic for instance.
  489. *)
  490. | TInst ({cl_kind=KTypeParameter _},_), TFun _ -> a2
  491. (*
  492. If we have a number, it is more accurate to cast it to the type parameter before wrapping it as dynamic
  493. Ignore dynamic method (#7166)
  494. *)
  495. | TInst ({cl_kind=KTypeParameter _},_), t when is_number (to_type ctx t) && (match f with FInstance (_,_,{ cf_kind = Var _ | Method MethDynamic }) -> false | _ -> true) ->
  496. (name, opt, TAbstract (fake_tnull,[t]))
  497. | _ ->
  498. a
  499. ) args args2, ret)
  500. | _ -> ft)
  501. | TLocal v -> v.v_type
  502. | TParenthesis e -> loop e
  503. | TArray (arr,_) ->
  504. let rec loop t =
  505. match follow t with
  506. | TInst({ cl_path = [],"Array" },[t]) -> t
  507. | TAbstract (a,pl) -> loop (Abstract.get_underlying_type a pl)
  508. | _ -> t_dynamic
  509. in
  510. loop arr.etype
  511. | _ -> e.etype
  512. in
  513. to_type ctx (loop e)
  514. and class_type ?(tref=None) ctx c pl statics =
  515. let c = if (has_class_flag c CExtern) then resolve_class ctx c pl statics else c in
  516. let key_path = (if statics then "$" ^ snd c.cl_path else snd c.cl_path) :: fst c.cl_path in
  517. try
  518. PMap.find key_path ctx.cached_types
  519. with Not_found when (has_class_flag c CInterface) && not statics ->
  520. let vp = {
  521. vfields = [||];
  522. vindex = PMap.empty;
  523. } in
  524. let t = HVirtual vp in
  525. ctx.cached_types <- PMap.add key_path t ctx.cached_types;
  526. let rec loop c =
  527. let rec concat_uniq fields pfields =
  528. match pfields with
  529. | (n,_,_) as pf::pfl -> if List.exists (fun (n1,_,_) -> n1 = n) fields then concat_uniq fields pfl else concat_uniq (pf::fields) pfl
  530. | [] -> fields
  531. in
  532. let pfields = List.fold_left (fun acc (i,_) -> loop i @ acc) [] c.cl_implements in
  533. let fields = PMap.fold (fun cf acc -> cfield_type ctx cf :: acc) c.cl_fields [] in
  534. concat_uniq fields pfields
  535. in
  536. let fields = loop c in
  537. let fields = List.sort (fun (n1,_,_) (n2,_,_) -> compare n1 n2) fields in
  538. vp.vfields <- Array.of_list fields;
  539. Array.iteri (fun i (n,_,_) -> vp.vindex <- PMap.add n i vp.vindex) vp.vfields;
  540. t
  541. | Not_found ->
  542. let pname = s_type_path (List.tl key_path, List.hd key_path) in
  543. let p = {
  544. pname = pname;
  545. pid = alloc_string ctx pname;
  546. psuper = None;
  547. pclassglobal = None;
  548. pproto = [||];
  549. pfields = [||];
  550. pindex = PMap.empty;
  551. pvirtuals = [||];
  552. pfunctions = PMap.empty;
  553. pnfields = -1;
  554. pinterfaces = PMap.empty;
  555. pbindings = [];
  556. } in
  557. let t = (if Meta.has Meta.Struct c.cl_meta && not statics then HStruct p else HObj p) in
  558. (match tref with
  559. | None -> ()
  560. | Some r -> r := Some t);
  561. ctx.ct_depth <- ctx.ct_depth + 1;
  562. ctx.cached_types <- PMap.add key_path t ctx.cached_types;
  563. if c.cl_path = ([],"Array") then die "" __LOC__;
  564. if c == ctx.base_class then begin
  565. if statics then die "" __LOC__;
  566. p.pnfields <- 1;
  567. end;
  568. let tsup = (match c.cl_super with
  569. | Some (csup,pl) when not statics -> Some (class_type ctx csup [] statics)
  570. | _ -> if statics then Some (class_type ctx ctx.base_class [] false) else None
  571. ) in
  572. let start_field, virtuals = (match tsup with
  573. | None -> 0, [||]
  574. | Some ((HObj psup | HStruct psup) as pt) ->
  575. if is_struct t <> is_struct pt then abort (if is_struct t then "Struct cannot extend a not struct class" else "Class cannot extend a struct") c.cl_pos;
  576. if psup.pnfields < 0 then die "" __LOC__;
  577. p.psuper <- Some psup;
  578. psup.pnfields, psup.pvirtuals
  579. | _ -> die "" __LOC__
  580. ) in
  581. let fa = DynArray.create() and pa = DynArray.create() and virtuals = DynArray.of_array virtuals in
  582. let add_field name get_t =
  583. let fid = DynArray.length fa + start_field in
  584. let str = alloc_string ctx name in
  585. p.pindex <- PMap.add name (fid, HVoid) p.pindex;
  586. DynArray.add fa (name, str, HVoid);
  587. ctx.ct_delayed <- (fun() ->
  588. let t = get_t() in
  589. p.pindex <- PMap.add name (fid, t) p.pindex;
  590. Array.set p.pfields (fid - start_field) (name, str, t);
  591. ) :: ctx.ct_delayed;
  592. fid
  593. in
  594. List.iter (fun f ->
  595. if is_extern_field f || (statics && f.cf_name = "__meta__") then () else
  596. let fid = (match f.cf_kind with
  597. | Method m when m <> MethDynamic && not statics ->
  598. let g = alloc_fid ctx c f in
  599. p.pfunctions <- PMap.add f.cf_name g p.pfunctions;
  600. let virt = if has_class_field_flag f CfOverride then
  601. let vid = (try -(fst (get_index f.cf_name p))-1 with Not_found -> die "" __LOC__) in
  602. DynArray.set virtuals vid g;
  603. Some vid
  604. else if is_overridden ctx c f then begin
  605. let vid = DynArray.length virtuals in
  606. DynArray.add virtuals g;
  607. p.pindex <- PMap.add f.cf_name (-vid-1,HVoid) p.pindex;
  608. Some vid
  609. end else
  610. None
  611. in
  612. DynArray.add pa { fname = f.cf_name; fid = alloc_string ctx f.cf_name; fmethod = g; fvirtual = virt; };
  613. None
  614. | Method MethDynamic when has_class_field_flag f CfOverride ->
  615. Some (try fst (get_index f.cf_name p) with Not_found -> die "" __LOC__)
  616. | _ ->
  617. let fid = add_field f.cf_name (fun() ->
  618. let t = to_type ctx f.cf_type in
  619. if has_meta (Meta.Custom ":packed") f.cf_meta then begin
  620. (match t with HStruct _ -> () | _ -> abort "Packed field should be struct" f.cf_pos);
  621. HPacked t
  622. end else t
  623. ) in
  624. Some fid
  625. ) in
  626. match f.cf_kind, f.cf_expr, fid with
  627. | Method _, Some _, Some fid -> p.pbindings <- (fid, alloc_fun_path ctx c.cl_path f.cf_name) :: p.pbindings
  628. | _ -> ()
  629. ) (if statics then c.cl_ordered_statics else c.cl_ordered_fields);
  630. if not statics then begin
  631. (* add interfaces *)
  632. List.iter (fun (i,pl) ->
  633. let rid = ref (-1) in
  634. rid := add_field "" (fun() ->
  635. let t = to_type ctx (TInst (i,pl)) in
  636. p.pinterfaces <- PMap.add t !rid p.pinterfaces;
  637. t
  638. );
  639. ) c.cl_implements;
  640. (* check toString *)
  641. (try
  642. let cf = PMap.find "toString" c.cl_fields in
  643. if has_class_field_flag cf CfOverride || PMap.mem "__string" c.cl_fields || not (is_to_string cf.cf_type) then raise Not_found;
  644. DynArray.add pa { fname = "__string"; fid = alloc_string ctx "__string"; fmethod = alloc_fun_path ctx c.cl_path "__string"; fvirtual = None; }
  645. with Not_found ->
  646. ());
  647. end else begin
  648. (match c.cl_constructor with
  649. | Some f when not (is_extern_field f) ->
  650. p.pbindings <- ((try fst (get_index "__constructor__" p) with Not_found -> die "" __LOC__),alloc_fid ctx c f) :: p.pbindings
  651. | _ -> ());
  652. end;
  653. p.pnfields <- DynArray.length fa + start_field;
  654. p.pfields <- DynArray.to_array fa;
  655. p.pproto <- DynArray.to_array pa;
  656. p.pvirtuals <- DynArray.to_array virtuals;
  657. ctx.ct_depth <- ctx.ct_depth - 1;
  658. if ctx.ct_depth = 0 then begin
  659. let todo = ctx.ct_delayed in
  660. ctx.ct_delayed <- [];
  661. List.iter (fun f -> f()) todo;
  662. end;
  663. if not statics && c != ctx.core_type && c != ctx.core_enum then p.pclassglobal <- Some (fst (class_global ctx (if statics then ctx.base_class else c)));
  664. t
  665. and enum_type ?(tref=None) ctx e =
  666. let key_path = snd e.e_path :: fst e.e_path in
  667. try
  668. PMap.find key_path ctx.cached_types
  669. with Not_found ->
  670. let ename = s_type_path e.e_path in
  671. let et = {
  672. eglobal = None;
  673. ename = ename;
  674. eid = alloc_string ctx ename;
  675. efields = [||];
  676. } in
  677. let t = HEnum et in
  678. (match tref with
  679. | None -> ()
  680. | Some r -> r := Some t);
  681. ctx.cached_types <- PMap.add key_path t ctx.cached_types;
  682. et.efields <- Array.of_list (List.map (fun f ->
  683. let f = PMap.find f e.e_constrs in
  684. let args = (match f.ef_type with
  685. | TFun (args,_) -> Array.of_list (List.map (fun (_,_,t) -> to_type ctx t) args)
  686. | _ -> [||]
  687. ) in
  688. (f.ef_name, alloc_string ctx f.ef_name, args)
  689. ) e.e_names);
  690. let ct = enum_class ctx e in
  691. et.eglobal <- Some (alloc_global ctx (match ct with HObj o -> o.pname | _ -> die "" __LOC__) ct);
  692. t
  693. and enum_class ctx e =
  694. let key_path = ("$" ^ snd e.e_path) :: fst e.e_path in
  695. try
  696. PMap.find key_path ctx.cached_types
  697. with Not_found ->
  698. let pname = s_type_path (List.tl key_path, List.hd key_path) in
  699. let p = {
  700. pname = pname;
  701. pid = alloc_string ctx pname;
  702. psuper = None;
  703. pclassglobal = None;
  704. pproto = [||];
  705. pfields = [||];
  706. pindex = PMap.empty;
  707. pvirtuals = [||];
  708. pfunctions = PMap.empty;
  709. pnfields = -1;
  710. pinterfaces = PMap.empty;
  711. pbindings = [];
  712. } in
  713. let t = HObj p in
  714. ctx.cached_types <- PMap.add key_path t ctx.cached_types;
  715. p.psuper <- Some (match class_type ctx ctx.base_enum [] false with HObj o -> o | _ -> die "" __LOC__);
  716. t
  717. and alloc_fun_path ctx path name =
  718. lookup ctx.cfids (name, path) (fun() -> ())
  719. and alloc_fid ctx c f =
  720. match f.cf_kind with
  721. | Var _ -> die "" __LOC__
  722. | _ -> alloc_fun_path ctx c.cl_path f.cf_name
  723. and alloc_eid ctx e f =
  724. alloc_fun_path ctx e.e_path f.ef_name
  725. and alloc_function_name ctx f =
  726. alloc_fun_path ctx ([],"") f
  727. and alloc_global ctx name t =
  728. lookup ctx.cglobals name (fun() -> t)
  729. and class_global ?(resolve=true) ctx c =
  730. let static = c != ctx.base_class in
  731. let c = if resolve && is_array_type (HObj { null_proto with pname = s_type_path c.cl_path }) then ctx.array_impl.abase else c in
  732. let c = resolve_class ctx c (extract_param_types c.cl_params) static in
  733. let t = class_type ctx c [] static in
  734. alloc_global ctx ("$" ^ s_type_path c.cl_path) t, t
  735. let resolve_class_global ctx cpath =
  736. lookup ctx.cglobals ("$" ^ cpath) (fun() -> die "" __LOC__)
  737. let resolve_type ctx path =
  738. PMap.find path ctx.cached_types
  739. let alloc_std ctx name args ret =
  740. let lib = "std" in
  741. (* different from :hlNative to prevent mismatch *)
  742. let nid = lookup ctx.cnatives ("$" ^ name ^ "@" ^ lib, -1) (fun() ->
  743. let fid = alloc_fun_path ctx ([],"std") name in
  744. Hashtbl.add ctx.defined_funs fid ();
  745. (alloc_string ctx lib, alloc_string ctx name,HFun (args,ret),fid)
  746. ) in
  747. let _,_,_,fid = DynArray.get ctx.cnatives.arr nid in
  748. fid
  749. let alloc_fresh ctx t =
  750. let rid = DynArray.length ctx.m.mregs.arr in
  751. DynArray.add ctx.m.mregs.arr t;
  752. rid
  753. let alloc_tmp ctx t =
  754. if not ctx.optimize then alloc_fresh ctx t else
  755. let a = try PMap.find t ctx.m.mallocs with Not_found ->
  756. let a = {
  757. a_all = [];
  758. a_hold = [];
  759. } in
  760. ctx.m.mallocs <- PMap.add t a ctx.m.mallocs;
  761. a
  762. in
  763. match a.a_all with
  764. | [] ->
  765. let r = alloc_fresh ctx t in
  766. a.a_all <- [r];
  767. r
  768. | r :: _ ->
  769. r
  770. let current_pos ctx =
  771. DynArray.length ctx.m.mops
  772. let rtype ctx r =
  773. DynArray.get ctx.m.mregs.arr r
  774. let hold ctx r =
  775. if not ctx.optimize then () else
  776. let t = rtype ctx r in
  777. let a = PMap.find t ctx.m.mallocs in
  778. let rec loop l =
  779. match l with
  780. | [] -> if List.mem r a.a_hold then [] else die "" __LOC__
  781. | n :: l when n = r -> l
  782. | n :: l -> n :: loop l
  783. in
  784. a.a_all <- loop a.a_all;
  785. a.a_hold <- r :: a.a_hold
  786. let free ctx r =
  787. if not ctx.optimize then () else
  788. let t = rtype ctx r in
  789. let a = PMap.find t ctx.m.mallocs in
  790. let last = ref true in
  791. let rec loop l =
  792. match l with
  793. | [] -> die "" __LOC__
  794. | n :: l when n = r ->
  795. if List.mem r l then last := false;
  796. l
  797. | n :: l -> n :: loop l
  798. in
  799. a.a_hold <- loop a.a_hold;
  800. (* insert sorted *)
  801. let rec loop l =
  802. match l with
  803. | [] -> [r]
  804. | n :: _ when n > r -> r :: l
  805. | n :: l -> n :: loop l
  806. in
  807. if !last then a.a_all <- loop a.a_all
  808. let decl_var ctx v =
  809. ctx.m.mdeclared <- v.v_id :: ctx.m.mdeclared
  810. let alloc_var ctx v new_var =
  811. if new_var then decl_var ctx v;
  812. try
  813. Hashtbl.find ctx.m.mvars v.v_id
  814. with Not_found ->
  815. let r = alloc_tmp ctx (to_type ctx v.v_type) in
  816. hold ctx r;
  817. Hashtbl.add ctx.m.mvars v.v_id r;
  818. r
  819. let push_op ctx o =
  820. DynArray.add ctx.m.mdebug ctx.m.mcurpos;
  821. DynArray.add ctx.m.mops o
  822. let op ctx o =
  823. match o with
  824. | OMov (a,b) when a = b ->
  825. ()
  826. | _ ->
  827. push_op ctx o
  828. let set_op ctx pos o =
  829. DynArray.set ctx.m.mops pos o
  830. let alloc_array ctx size et =
  831. let a = alloc_tmp ctx (HArray HDyn) in
  832. let b = alloc_tmp ctx (HArray et) in
  833. let rt = alloc_tmp ctx HType in
  834. op ctx (OType (rt,et));
  835. op ctx (OCall2 (a,alloc_std ctx "alloc_array" [HType;HI32] (HArray HDyn),rt,size));
  836. op ctx (OUnsafeCast(b,a));
  837. b
  838. let jump ctx f =
  839. let pos = current_pos ctx in
  840. op ctx (OJAlways (-1)); (* loop *)
  841. (fun() -> set_op ctx pos (f (current_pos ctx - pos - 1)))
  842. let jump_back ctx =
  843. let pos = current_pos ctx in
  844. op ctx (OLabel 0);
  845. (fun() -> op ctx (OJAlways (pos - current_pos ctx - 1)))
  846. let reg_int ctx v =
  847. let r = alloc_tmp ctx HI32 in
  848. op ctx (OInt (r,alloc_i32 ctx (Int32.of_int v)));
  849. r
  850. let shl ctx idx v =
  851. if v = 0 then
  852. idx
  853. else begin
  854. hold ctx idx;
  855. let rv = reg_int ctx v in
  856. let idx2 = alloc_tmp ctx HI32 in
  857. op ctx (OShl (idx2, idx, rv));
  858. free ctx idx;
  859. idx2;
  860. end
  861. let set_default ctx r =
  862. match rtype ctx r with
  863. | HUI8 | HUI16 | HI32 | HI64 ->
  864. op ctx (OInt (r,alloc_i32 ctx 0l))
  865. | HF32 | HF64 ->
  866. op ctx (OFloat (r,alloc_float ctx 0.))
  867. | HBool ->
  868. op ctx (OBool (r, false))
  869. | HType ->
  870. op ctx (OType (r, HVoid))
  871. | _ ->
  872. op ctx (ONull r)
  873. let read_mem ctx rdst bytes index t =
  874. match t with
  875. | HUI8 ->
  876. op ctx (OGetUI8 (rdst,bytes,index))
  877. | HUI16 ->
  878. op ctx (OGetUI16 (rdst,bytes,index))
  879. | HI32 | HI64 | HF32 | HF64 ->
  880. op ctx (OGetMem (rdst,bytes,index))
  881. | _ ->
  882. die "" __LOC__
  883. let write_mem ctx bytes index t r =
  884. match t with
  885. | HUI8 ->
  886. op ctx (OSetUI8 (bytes,index,r))
  887. | HUI16 ->
  888. op ctx (OSetUI16 (bytes,index,r))
  889. | HI32 | HI64 | HF32 | HF64 ->
  890. op ctx (OSetMem (bytes,index,r))
  891. | _ ->
  892. die "" __LOC__
  893. let common_type_number ctx t1 t2 p =
  894. if t1 == t2 then t1 else
  895. match t1, t2 with
  896. | HUI8, (HUI16 | HI32 | HI64 | HF32 | HF64) -> t2
  897. | HUI16, (HI32 | HI64 | HF32 | HF64) -> t2
  898. | (HI32 | HI64), HF32 -> t2 (* possible loss of precision *)
  899. | (HI32 | HI64 | HF32), HF64 -> t2
  900. | (HUI8|HUI16|HI32|HI64|HF32|HF64), (HUI8|HUI16|HI32|HI64|HF32|HF64) -> t1
  901. | _ ->
  902. die "" __LOC__
  903. let common_type ctx e1 e2 for_eq p =
  904. let t1 = to_type ctx e1.etype in
  905. let t2 = to_type ctx e2.etype in
  906. if t1 == t2 then t1 else
  907. match t1, t2 with
  908. | (HUI8|HUI16|HI32|HI64|HF32|HF64), (HUI8|HUI16|HI32|HI64|HF32|HF64) -> common_type_number ctx t1 t2 p
  909. | (HUI8|HUI16|HI32|HI64|HF32|HF64 as t1), (HNull t2)
  910. | (HNull t1), (HUI8|HUI16|HI32|HI64|HF32|HF64 as t2)
  911. | (HNull t1), (HNull t2)
  912. -> if for_eq then HNull (common_type_number ctx t1 t2 p) else common_type_number ctx t1 t2 p
  913. | HDyn, (HUI8|HUI16|HI32|HI64|HF32|HF64) -> HF64
  914. | (HUI8|HUI16|HI32|HI64|HF32|HF64), HDyn -> HF64
  915. | HDyn, _ -> HDyn
  916. | _, HDyn -> HDyn
  917. | _ when for_eq && safe_cast t1 t2 -> t2
  918. | _ when for_eq && safe_cast t2 t1 -> t1
  919. | HBool, HNull HBool when for_eq -> t2
  920. | HNull HBool, HBool when for_eq -> t1
  921. | HObj _, HVirtual _ | HVirtual _, HObj _ | HVirtual _ , HVirtual _ -> HDyn
  922. | HFun _, HFun _ -> HDyn
  923. | _ ->
  924. abort ("Can't find common type " ^ tstr t1 ^ " and " ^ tstr t2) p
  925. let captured_index ctx v =
  926. if not (has_var_flag v VCaptured) then None else try Some (PMap.find v.v_id ctx.m.mcaptured.c_map) with Not_found -> None
  927. let real_name v =
  928. let rec loop = function
  929. | [] -> v.v_name
  930. | (Meta.RealPath,[EConst (String(name,_)),_],_) :: _ -> name
  931. | _ :: l -> loop l
  932. in
  933. match loop v.v_meta with
  934. | "_gthis" -> "this"
  935. | name -> match v.v_kind with
  936. | VInlinedConstructorVariable sl -> String.concat "." sl
  937. | _ -> name
  938. let not_debug_var ctx v = match v.v_kind with
  939. | VUser _ -> false
  940. | VInlinedConstructorVariable _ -> false
  941. | _ -> true
  942. let add_assign ?(force=false) ctx v =
  943. if not force && not_debug_var ctx v then () else
  944. let name = real_name v in
  945. ctx.m.massign <- (alloc_string ctx name, current_pos ctx - 1) :: ctx.m.massign
  946. let add_capture ctx r =
  947. Array.iter (fun v ->
  948. let name = real_name v in
  949. ctx.m.massign <- (alloc_string ctx name, -(r+2)) :: ctx.m.massign
  950. ) ctx.m.mcaptured.c_vars
  951. let before_return ctx =
  952. let rec loop i =
  953. if i > 0 then begin
  954. op ctx (OEndTrap false);
  955. loop (i - 1)
  956. end
  957. in
  958. loop ctx.m.mtrys
  959. let before_break_continue ctx =
  960. let rec loop i =
  961. if i > 0 then begin
  962. op ctx (OEndTrap false);
  963. loop (i - 1)
  964. end
  965. in
  966. loop (ctx.m.mtrys - ctx.m.mloop_trys)
  967. let type_value ctx t p =
  968. match t with
  969. | TClassDecl c ->
  970. let g, t = class_global ctx c in
  971. let r = alloc_tmp ctx t in
  972. op ctx (OGetGlobal (r, g));
  973. r
  974. | TAbstractDecl a ->
  975. let r = alloc_tmp ctx (class_type ctx ctx.base_type [] false) in
  976. (match a.a_path with
  977. | [], "Int" -> op ctx (OGetGlobal (r, alloc_global ctx "$Int" (rtype ctx r)))
  978. | [], "Float" -> op ctx (OGetGlobal (r, alloc_global ctx "$Float" (rtype ctx r)))
  979. | [], "Bool" -> op ctx (OGetGlobal (r, alloc_global ctx "$Bool" (rtype ctx r)))
  980. | [], "Class" -> op ctx (OGetGlobal (r, fst (class_global ctx ctx.base_class)))
  981. | [], "Enum" -> op ctx (OGetGlobal (r, fst (class_global ctx ctx.base_enum)))
  982. | [], "Dynamic" -> op ctx (OGetGlobal (r, alloc_global ctx "$Dynamic" (rtype ctx r)))
  983. | _ -> abort ("Unsupported type value " ^ s_type_path (t_path t)) p);
  984. r
  985. | TEnumDecl e ->
  986. let r = alloc_tmp ctx (enum_class ctx e) in
  987. let rt = rtype ctx r in
  988. op ctx (OGetGlobal (r, alloc_global ctx (match rt with HObj o -> o.pname | _ -> die "" __LOC__) rt));
  989. r
  990. | TTypeDecl _ ->
  991. die "" __LOC__
  992. let rec eval_to ctx e (t:ttype) =
  993. match e.eexpr, t with
  994. | TConst (TInt i), HF64 ->
  995. let r = alloc_tmp ctx t in
  996. op ctx (OFloat (r,alloc_float ctx (Int32.to_float i)));
  997. r
  998. (* this causes a bug with NG, to be reviewed later
  999. | TConst (TInt i), HF32 ->
  1000. let r = alloc_tmp ctx t in
  1001. let bits = Int32.bits_of_float (Int32.to_float i) in
  1002. op ctx (OFloat (r,alloc_float ctx (Int64.float_of_bits (Int64.of_int32 bits))));
  1003. r
  1004. | TConst (TFloat f), HF32 ->
  1005. let r = alloc_tmp ctx t in
  1006. let bits = Int32.bits_of_float (float_of_string f) in
  1007. op ctx (OFloat (r,alloc_float ctx (Int64.float_of_bits (Int64.of_int32 bits))));
  1008. r
  1009. *)
  1010. | _ ->
  1011. let r = eval_expr ctx e in
  1012. cast_to ctx r t e.epos
  1013. and to_string ctx (r:reg) p =
  1014. let rt = rtype ctx r in
  1015. if safe_cast rt ctx.tstring then r else
  1016. match rt with
  1017. | HUI8 | HUI16 | HI32 ->
  1018. let len = alloc_tmp ctx HI32 in
  1019. hold ctx len;
  1020. let lref = alloc_tmp ctx (HRef HI32) in
  1021. let bytes = alloc_tmp ctx HBytes in
  1022. op ctx (ORef (lref,len));
  1023. op ctx (OCall2 (bytes,alloc_std ctx "itos" [HI32;HRef HI32] HBytes,cast_to ctx r HI32 p,lref));
  1024. let out = alloc_tmp ctx ctx.tstring in
  1025. op ctx (OCall2 (out,alloc_fun_path ctx ([],"String") "__alloc__",bytes,len));
  1026. free ctx len;
  1027. out
  1028. | HF32 | HF64 ->
  1029. let len = alloc_tmp ctx HI32 in
  1030. let lref = alloc_tmp ctx (HRef HI32) in
  1031. let bytes = alloc_tmp ctx HBytes in
  1032. op ctx (ORef (lref,len));
  1033. op ctx (OCall2 (bytes,alloc_std ctx "ftos" [HF64;HRef HI32] HBytes,cast_to ctx r HF64 p,lref));
  1034. let out = alloc_tmp ctx ctx.tstring in
  1035. op ctx (OCall2 (out,alloc_fun_path ctx ([],"String") "__alloc__",bytes,len));
  1036. out
  1037. | _ ->
  1038. let r = cast_to ctx r HDyn p in
  1039. let out = alloc_tmp ctx ctx.tstring in
  1040. op ctx (OJNotNull (r,2));
  1041. op ctx (ONull out);
  1042. op ctx (OJAlways 1);
  1043. op ctx (OCall1 (out,alloc_fun_path ctx ([],"Std") "string",r));
  1044. out
  1045. and cast_to ?(force=false) ctx (r:reg) (t:ttype) p =
  1046. let rt = rtype ctx r in
  1047. if safe_cast rt t then r else
  1048. match rt, t with
  1049. | _, HVoid ->
  1050. alloc_tmp ctx HVoid
  1051. | HVirtual _, HVirtual _ ->
  1052. let tmp = alloc_tmp ctx HDyn in
  1053. op ctx (OMov (tmp,r));
  1054. cast_to ctx tmp t p
  1055. | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64), (HF32 | HF64) ->
  1056. let tmp = alloc_tmp ctx t in
  1057. op ctx (OToSFloat (tmp, r));
  1058. tmp
  1059. | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64), (HUI8 | HUI16 | HI32 | HI64) ->
  1060. let tmp = alloc_tmp ctx t in
  1061. op ctx (OToInt (tmp, r));
  1062. tmp
  1063. | HObj o, HVirtual _ ->
  1064. let out = alloc_tmp ctx t in
  1065. (try
  1066. let rec lookup_intf o =
  1067. try
  1068. PMap.find t o.pinterfaces
  1069. with Not_found ->
  1070. match o.psuper with
  1071. | None -> raise Not_found
  1072. | Some o -> lookup_intf o
  1073. in
  1074. let fid = lookup_intf o in
  1075. (* memoisation *)
  1076. let need_null_check r =
  1077. not (r = 0 && ctx.m.mhasthis)
  1078. in
  1079. let jend = if need_null_check r then
  1080. let jnull = jump ctx (fun d -> OJNotNull (r,d)) in
  1081. op ctx (ONull out);
  1082. let jend = jump ctx (fun d -> OJAlways d) in
  1083. jnull();
  1084. jend
  1085. else
  1086. (fun() -> ())
  1087. in
  1088. op ctx (OField (out, r, fid));
  1089. let j = jump ctx (fun d -> OJNotNull (out,d)) in
  1090. op ctx (OToVirtual (out,r));
  1091. op ctx (OSetField (r, fid, out));
  1092. jend();
  1093. j();
  1094. with Not_found ->
  1095. (* not an interface *)
  1096. op ctx (OToVirtual (out,r)));
  1097. out
  1098. | (HDynObj | HDyn) , HVirtual _ ->
  1099. let out = alloc_tmp ctx t in
  1100. op ctx (OToVirtual (out,r));
  1101. out
  1102. | HDyn, _ ->
  1103. let out = alloc_tmp ctx t in
  1104. op ctx (OSafeCast (out, r));
  1105. out
  1106. | HNull rt, _ when t = rt ->
  1107. let out = alloc_tmp ctx t in
  1108. op ctx (OSafeCast (out, r));
  1109. out
  1110. | HVoid, HDyn ->
  1111. let tmp = alloc_tmp ctx HDyn in
  1112. op ctx (ONull tmp);
  1113. tmp
  1114. | _ , HDyn ->
  1115. let tmp = alloc_tmp ctx HDyn in
  1116. op ctx (OToDyn (tmp, r));
  1117. tmp
  1118. | _, HNull t when rt == t ->
  1119. let tmp = alloc_tmp ctx (HNull t) in
  1120. op ctx (OToDyn (tmp, r));
  1121. tmp
  1122. | HNull t1, HNull t2 ->
  1123. let j = jump ctx (fun n -> OJNull (r,n)) in
  1124. let rtmp = alloc_tmp ctx t1 in
  1125. op ctx (OSafeCast (rtmp,r));
  1126. let out = cast_to ctx rtmp t p in
  1127. op ctx (OJAlways 1);
  1128. j();
  1129. op ctx (ONull out);
  1130. out
  1131. | HRef t1, HNull t2 ->
  1132. let j = jump ctx (fun n -> OJNull (r,n)) in
  1133. let rtmp = alloc_tmp ctx t1 in
  1134. op ctx (OUnref (rtmp,r));
  1135. let out = cast_to ctx rtmp t p in
  1136. op ctx (OJAlways 1);
  1137. j();
  1138. op ctx (ONull out);
  1139. out
  1140. | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64), HNull ((HF32 | HF64) as t) ->
  1141. let tmp = alloc_tmp ctx t in
  1142. op ctx (OToSFloat (tmp, r));
  1143. let r = alloc_tmp ctx (HNull t) in
  1144. op ctx (OToDyn (r,tmp));
  1145. r
  1146. | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64), HNull ((HUI8 | HUI16 | HI32) as t) ->
  1147. let tmp = alloc_tmp ctx t in
  1148. op ctx (OToInt (tmp, r));
  1149. let r = alloc_tmp ctx (HNull t) in
  1150. op ctx (OToDyn (r,tmp));
  1151. r
  1152. | HNull ((HUI8 | HUI16 | HI32 | HI64) as it), (HF32 | HF64) ->
  1153. let i = alloc_tmp ctx it in
  1154. op ctx (OSafeCast (i,r));
  1155. let tmp = alloc_tmp ctx t in
  1156. op ctx (OToSFloat (tmp, i));
  1157. tmp
  1158. | HNull ((HF32 | HF64) as it), (HUI8 | HUI16 | HI32 | HI64) ->
  1159. let i = alloc_tmp ctx it in
  1160. op ctx (OSafeCast (i,r));
  1161. let tmp = alloc_tmp ctx t in
  1162. op ctx (OToInt (tmp, i));
  1163. tmp
  1164. | HFun (args1,ret1), HFun (args2, ret2) when List.length args1 = List.length args2 ->
  1165. let fid = gen_method_wrapper ctx rt t p in
  1166. let fr = alloc_tmp ctx t in
  1167. op ctx (OJNotNull (r,2));
  1168. op ctx (ONull fr);
  1169. op ctx (OJAlways 1);
  1170. op ctx (OInstanceClosure (fr,fid,r));
  1171. fr
  1172. | HObj _, HObj _ when is_array_type rt && is_array_type t ->
  1173. let out = alloc_tmp ctx t in
  1174. op ctx (OSafeCast (out, r));
  1175. out
  1176. | HNull _, HRef t2 ->
  1177. let out = alloc_tmp ctx t in
  1178. op ctx (OJNotNull (r,2));
  1179. op ctx (ONull out);
  1180. let j = jump ctx (fun n -> OJAlways n) in
  1181. let r = cast_to ctx r t2 p in
  1182. let r2 = alloc_tmp ctx t2 in
  1183. op ctx (OMov (r2, r));
  1184. hold ctx r2; (* retain *)
  1185. op ctx (ORef (out,r2));
  1186. j();
  1187. out
  1188. | _, HRef t2 ->
  1189. let r = cast_to ctx r t2 p in
  1190. let r2 = alloc_tmp ctx t2 in
  1191. op ctx (OMov (r2, r));
  1192. hold ctx r2; (* retain *)
  1193. let out = alloc_tmp ctx t in
  1194. op ctx (ORef (out,r2));
  1195. out
  1196. | _ ->
  1197. if force then
  1198. let out = alloc_tmp ctx t in
  1199. op ctx (OSafeCast (out, r));
  1200. out
  1201. else
  1202. abort ("Don't know how to cast " ^ tstr rt ^ " to " ^ tstr t) p
  1203. and unsafe_cast_to ?(debugchk=true) ctx (r:reg) (t:ttype) p =
  1204. let rt = rtype ctx r in
  1205. if safe_cast rt t then
  1206. r
  1207. else
  1208. match rt with
  1209. | HFun _ ->
  1210. cast_to ctx r t p
  1211. | HDyn when is_array_type t ->
  1212. cast_to ctx r t p
  1213. | (HDyn | HObj _) when (match t with HVirtual _ -> true | _ -> false) ->
  1214. cast_to ctx r t p
  1215. | HObj _ when is_array_type rt && is_array_type t ->
  1216. cast_to ctx r t p
  1217. | HVirtual _ when (match t with HObj _ | HVirtual _ -> true | _ -> false) ->
  1218. cast_to ~force:true ctx r t p
  1219. | _ ->
  1220. if is_dynamic (rtype ctx r) && is_dynamic t then
  1221. let r2 = alloc_tmp ctx t in
  1222. op ctx (OUnsafeCast (r2,r));
  1223. if ctx.com.debug && debugchk then begin
  1224. hold ctx r2;
  1225. let r3 = cast_to ~force:true ctx r t p in
  1226. let j = jump ctx (fun n -> OJEq (r2,r3,n)) in
  1227. op ctx (OAssert 0);
  1228. j();
  1229. free ctx r2;
  1230. end;
  1231. r2
  1232. else
  1233. cast_to ~force:true ctx r t p
  1234. and object_access ctx eobj t f =
  1235. match t with
  1236. | HObj p | HStruct p ->
  1237. (try
  1238. let fid = fst (get_index f.cf_name p) in
  1239. if f.cf_kind = Method MethNormal then
  1240. AInstanceProto (eobj, -fid-1)
  1241. else
  1242. AInstanceField (eobj, fid)
  1243. with Not_found ->
  1244. ADynamic (eobj, alloc_string ctx f.cf_name))
  1245. | HVirtual v ->
  1246. (try
  1247. let fid = PMap.find f.cf_name v.vindex in
  1248. if f.cf_kind = Method MethNormal then
  1249. AVirtualMethod (eobj, fid)
  1250. else
  1251. AInstanceField (eobj, fid)
  1252. with Not_found ->
  1253. ADynamic (eobj, alloc_string ctx f.cf_name))
  1254. | HDyn ->
  1255. ADynamic (eobj, alloc_string ctx f.cf_name)
  1256. | _ ->
  1257. abort ("Unsupported field access " ^ tstr t) eobj.epos
  1258. and direct_method_call ctx c f ethis =
  1259. if (match f.cf_kind with Method m -> m = MethDynamic | Var _ -> true) then
  1260. false
  1261. else if (has_class_flag c CInterface) then
  1262. false
  1263. else if (match c.cl_kind with KTypeParameter _ -> true | _ -> false) then
  1264. false
  1265. else if is_overridden ctx c f && ethis.eexpr <> TConst(TSuper) then
  1266. false
  1267. else
  1268. true
  1269. and get_access ctx e =
  1270. match e.eexpr with
  1271. | TField (ethis, a) ->
  1272. (match a, follow ethis.etype with
  1273. | FStatic (c,({ cf_kind = Var _ | Method MethDynamic } as f)), _ ->
  1274. let g, t = class_global ctx c in
  1275. AStaticVar (g, t, (match t with HObj o -> (try fst (get_index f.cf_name o) with Not_found -> die ~p:e.epos "" __LOC__) | _ -> die ~p:e.epos "" __LOC__))
  1276. | FStatic (c,({ cf_kind = Method _ } as f)), _ ->
  1277. AStaticFun (alloc_fid ctx c f)
  1278. | FClosure (Some (cdef,pl), f), TInst (c,_)
  1279. | FInstance (cdef,pl,f), TInst (c,_) when direct_method_call ctx c f ethis ->
  1280. (* cdef is the original definition, we want the last redefinition *)
  1281. let rec loop c =
  1282. if PMap.mem f.cf_name c.cl_fields then c else (match c.cl_super with None -> cdef | Some (c,_) -> loop c)
  1283. in
  1284. let last_def = loop c in
  1285. AInstanceFun (ethis, alloc_fid ctx (resolve_class ctx last_def pl false) f)
  1286. | (FInstance (cdef,pl,f) | FClosure (Some (cdef,pl), f)), _ ->
  1287. let rec loop t =
  1288. match follow t with
  1289. | TInst (c,pl) -> c, pl
  1290. | TAbstract (a,pl) -> loop (Abstract.get_underlying_type a pl)
  1291. | _ -> abort (s_type (print_context()) ethis.etype ^ " hl type should be interface") ethis.epos
  1292. in
  1293. let cdef, pl = if (has_class_flag cdef CInterface) then loop ethis.etype else cdef,pl in
  1294. object_access ctx ethis (class_type ctx cdef pl false) f
  1295. | (FAnon f | FClosure(None,f)), _ ->
  1296. object_access ctx ethis (to_type ctx ethis.etype) f
  1297. | FDynamic name, _ ->
  1298. ADynamic (ethis, alloc_string ctx name)
  1299. | FEnum (e,ef), _ ->
  1300. (match follow ef.ef_type with
  1301. | TFun _ -> AEnum (e,ef.ef_index)
  1302. | t -> AGlobal (alloc_global ctx (efield_name e ef) (to_type ctx t))))
  1303. | TLocal v ->
  1304. (match captured_index ctx v with
  1305. | None -> ALocal (v, alloc_var ctx v false)
  1306. | Some idx -> ACaptured idx)
  1307. | TParenthesis e ->
  1308. get_access ctx e
  1309. | TArray (a,i) ->
  1310. let rec loop t =
  1311. match follow t with
  1312. | TInst({ cl_path = [],"Array" },[t]) ->
  1313. let a = eval_null_check ctx a in
  1314. hold ctx a;
  1315. let i = eval_to ctx i HI32 in
  1316. free ctx a;
  1317. let t = to_type ctx t in
  1318. AArray (a,(t,t),i)
  1319. | TInst ({ cl_path = ["hl"],"Abstract" },[TInst({ cl_kind = KExpr (EConst (String("hl_carray",_)),_) },_)]) ->
  1320. let a = eval_expr ctx a in
  1321. hold ctx a;
  1322. let i = eval_to ctx i HI32 in
  1323. free ctx a;
  1324. let t = to_type ctx e.etype in
  1325. ACArray (a,t,i)
  1326. | TAbstract (a,pl) ->
  1327. loop (Abstract.get_underlying_type a pl)
  1328. | _ ->
  1329. let a = eval_to ctx a (class_type ctx ctx.array_impl.adyn [] false) in
  1330. op ctx (ONullCheck a);
  1331. hold ctx a;
  1332. let i = eval_to ctx i HI32 in
  1333. free ctx a;
  1334. AArray (a,(HDyn,to_type ctx e.etype),i)
  1335. in
  1336. loop a.etype
  1337. | _ ->
  1338. ANone
  1339. and array_read ctx ra (at,vt) ridx p =
  1340. match at with
  1341. | HUI8 | HUI16 | HI32 | HF32 | HF64 | HI64 ->
  1342. (* check bounds *)
  1343. hold ctx ridx;
  1344. let length = alloc_tmp ctx HI32 in
  1345. free ctx ridx;
  1346. op ctx (OField (length, ra, 0));
  1347. let j = jump ctx (fun i -> OJULt (ridx,length,i)) in
  1348. let r = alloc_tmp ctx (match at with HUI8 | HUI16 -> HI32 | _ -> at) in
  1349. (match at with
  1350. | HUI8 | HUI16 | HI32 | HI64 ->
  1351. op ctx (OInt (r,alloc_i32 ctx 0l));
  1352. | HF32 | HF64 ->
  1353. op ctx (OFloat (r,alloc_float ctx 0.));
  1354. | _ ->
  1355. die "" __LOC__);
  1356. let jend = jump ctx (fun i -> OJAlways i) in
  1357. j();
  1358. let hbytes = alloc_tmp ctx HBytes in
  1359. op ctx (OField (hbytes, ra, 1));
  1360. read_mem ctx r hbytes (shl ctx ridx (type_size_bits at)) at;
  1361. jend();
  1362. cast_to ctx r vt p
  1363. | HDyn ->
  1364. (* call getDyn *)
  1365. let r = alloc_tmp ctx HDyn in
  1366. op ctx (OCallMethod (r,0,[ra;ridx]));
  1367. unsafe_cast_to ctx r vt p
  1368. | _ ->
  1369. (* check bounds *)
  1370. hold ctx ridx;
  1371. let length = alloc_tmp ctx HI32 in
  1372. free ctx ridx;
  1373. op ctx (OField (length,ra,0));
  1374. let j = jump ctx (fun i -> OJULt (ridx,length,i)) in
  1375. let r = alloc_tmp ctx vt in
  1376. set_default ctx r;
  1377. let jend = jump ctx (fun i -> OJAlways i) in
  1378. j();
  1379. let tmp = alloc_tmp ctx HDyn in
  1380. let harr = alloc_tmp ctx (HArray vt) in
  1381. op ctx (OField (harr,ra,1));
  1382. op ctx (OGetArray (tmp,harr,ridx));
  1383. op ctx (OMov (r,unsafe_cast_to ctx tmp vt p));
  1384. jend();
  1385. r
  1386. and jump_expr ctx e jcond =
  1387. match e.eexpr with
  1388. | TParenthesis e ->
  1389. jump_expr ctx e jcond
  1390. | TUnop (Not,_,e) ->
  1391. jump_expr ctx e (not jcond)
  1392. | TBinop ((OpEq | OpGte | OpLte),{ eexpr = TConst(TNull) },e) | TBinop ((OpEq | OpGte | OpLte),e,{ eexpr = TConst(TNull) }) ->
  1393. let r = eval_expr ctx e in
  1394. if is_nullable(rtype ctx r) then
  1395. jump ctx (fun i -> if jcond then OJNull (r,i) else OJNotNull (r,i))
  1396. else if not jcond then
  1397. jump ctx (fun i -> OJAlways i)
  1398. else
  1399. (fun i -> ())
  1400. | TBinop (OpNotEq,{ eexpr = TConst(TNull) },e) | TBinop (OpNotEq,e,{ eexpr = TConst(TNull) }) ->
  1401. let r = eval_expr ctx e in
  1402. if is_nullable(rtype ctx r) then
  1403. jump ctx (fun i -> if jcond then OJNotNull (r,i) else OJNull (r,i))
  1404. else if jcond then
  1405. jump ctx (fun i -> OJAlways i)
  1406. else
  1407. (fun i -> ())
  1408. | TBinop (OpEq | OpNotEq as jop, e1, e2) ->
  1409. let jumpeq r1 r2 = jump ctx (fun i ->
  1410. match jop with
  1411. | OpEq -> if jcond then OJEq (r1,r2,i) else OJNotEq (r1,r2,i)
  1412. | OpNotEq -> if jcond then OJNotEq (r1,r2,i) else OJEq (r1,r2,i)
  1413. | _ -> die "" __LOC__
  1414. ) in
  1415. let nullisfalse = match jop with
  1416. | OpEq -> jcond
  1417. | OpNotEq -> not jcond
  1418. | _ -> die "" __LOC__
  1419. in
  1420. let t1 = to_type ctx e1.etype in
  1421. let t2 = to_type ctx e2.etype in
  1422. (match t1, t2 with
  1423. | HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
  1424. | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
  1425. | HNull (HBool as ti1), (HBool as ti2)
  1426. | (HBool as ti1), HNull (HBool as ti2)
  1427. ->
  1428. let t1,t2,e1,e2 = if is_nullt t2 then t2,t1,e2,e1 else t1,t2,e1,e2 in
  1429. let r1 = eval_expr ctx e1 in
  1430. hold ctx r1;
  1431. let jnull = if is_nullt t1 then jump ctx (fun i -> OJNull (r1, i)) else (fun i -> ()) in
  1432. let t = common_type_number ctx ti1 ti2 e.epos in (* HBool has t==ti1==ti2 *)
  1433. let a = cast_to ctx r1 t e1.epos in
  1434. hold ctx a;
  1435. let b = eval_to ctx e2 t in
  1436. free ctx a;
  1437. free ctx r1;
  1438. let j = jumpeq a b in
  1439. if nullisfalse then (jnull(););
  1440. (fun() -> if not nullisfalse then (jnull();); j());
  1441. | _ ->
  1442. let t = common_type ctx e1 e2 true e.epos in
  1443. let a = eval_to ctx e1 t in
  1444. hold ctx a;
  1445. let b = eval_to ctx e2 t in
  1446. free ctx a;
  1447. let j = jumpeq a b in
  1448. (fun() -> j());
  1449. )
  1450. | TBinop (OpGt | OpGte | OpLt | OpLte as jop, e1, e2) ->
  1451. let t1 = to_type ctx e1.etype in
  1452. let t2 = to_type ctx e2.etype in
  1453. let unsigned = unsigned_op e1 e2 in
  1454. let jumpcmp t r1 r2 = jump ctx (fun i ->
  1455. let lt a b = if unsigned then OJULt (a,b,i) else if not jcond && is_float t then OJNotGte (a,b,i) else OJSLt (a,b,i) in
  1456. let gte a b = if unsigned then OJUGte (a,b,i) else if not jcond && is_float t then OJNotLt (a,b,i) else OJSGte (a,b,i) in
  1457. match jop with
  1458. | OpGt -> if jcond then lt r2 r1 else gte r2 r1
  1459. | OpGte -> if jcond then gte r1 r2 else lt r1 r2
  1460. | OpLt -> if jcond then lt r1 r2 else gte r1 r2
  1461. | OpLte -> if jcond then gte r2 r1 else lt r2 r1
  1462. | _ -> die "" __LOC__
  1463. ) in
  1464. (match t1, t2 with
  1465. | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
  1466. | HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
  1467. | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
  1468. | HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
  1469. ->
  1470. if ctx.w_null_compare && (is_nullt t1 || is_nullt t2) then
  1471. ctx.com.warning WGenerator [] (Printf.sprintf "Null compare: %s %s %s" (tstr t1) (s_binop jop) (tstr t2)) e.epos;
  1472. let r1 = eval_expr ctx e1 in
  1473. hold ctx r1;
  1474. let jnull1 = if is_nullt t1 then jump ctx (fun i -> OJNull (r1, i)) else (fun i -> ()) in
  1475. let r2 = eval_expr ctx e2 in
  1476. hold ctx r2;
  1477. let jnull2 = if is_nullt t2 then jump ctx (fun i -> OJNull (r2, i)) else (fun i -> ()) in
  1478. let t = common_type_number ctx ti1 ti2 e.epos in
  1479. let a = cast_to ctx r1 t e1.epos in
  1480. hold ctx a;
  1481. let b = cast_to ctx r2 t e2.epos in
  1482. free ctx a;
  1483. free ctx r1;
  1484. free ctx r2;
  1485. let j = jumpcmp t a b in
  1486. if jcond then (jnull1(); jnull2(););
  1487. (fun() -> if not jcond then (jnull1(); jnull2();); j());
  1488. | HObj { pname = "String" }, HObj { pname = "String" }
  1489. | HDyn, _
  1490. | _, HDyn
  1491. ->
  1492. let t = common_type ctx e1 e2 false e.epos in
  1493. let a = eval_to ctx e1 t in
  1494. hold ctx a;
  1495. let b = eval_to ctx e2 t in
  1496. free ctx a;
  1497. let j = jumpcmp t a b in
  1498. (fun() -> j());
  1499. | _ ->
  1500. abort ("Don't know how to compare " ^ tstr t1 ^ " and " ^ tstr t2) e.epos
  1501. )
  1502. | TBinop (OpBoolAnd, e1, e2) ->
  1503. let j = jump_expr ctx e1 false in
  1504. let j2 = jump_expr ctx e2 jcond in
  1505. if jcond then j();
  1506. (fun() -> if not jcond then j(); j2());
  1507. | TBinop (OpBoolOr, e1, e2) ->
  1508. let j = jump_expr ctx e1 true in
  1509. let j2 = jump_expr ctx e2 jcond in
  1510. if not jcond then j();
  1511. (fun() -> if jcond then j(); j2());
  1512. | _ ->
  1513. let r = eval_to ctx e HBool in
  1514. jump ctx (fun i -> if jcond then OJTrue (r,i) else OJFalse (r,i))
  1515. and eval_args ctx el t p =
  1516. let rl = List.map2 (fun e t ->
  1517. let r = (match e.eexpr, t with
  1518. | TConst TNull, HRef _ ->
  1519. let r = alloc_tmp ctx t in
  1520. op ctx (ONull r);
  1521. r
  1522. | _ ->
  1523. eval_to ctx e t
  1524. ) in
  1525. hold ctx r;
  1526. r
  1527. ) el (match t with HFun (args,_) -> args | HDyn -> List.map (fun _ -> HDyn) el | _ -> die "" __LOC__) in
  1528. List.iter (free ctx) rl;
  1529. set_curpos ctx p;
  1530. rl
  1531. and eval_null_check ctx e =
  1532. let r = eval_expr ctx e in
  1533. (match e.eexpr with
  1534. | TConst TThis | TConst TSuper -> ()
  1535. | _ -> op ctx (ONullCheck r));
  1536. r
  1537. and make_const ctx c p =
  1538. let cidx = lookup ctx.cconstants c (fun() ->
  1539. let fields, t = (match c with
  1540. | CString s ->
  1541. let str, len = to_utf8 s p in
  1542. [alloc_string ctx str; alloc_i32 ctx (Int32.of_int len)], ctx.tstring
  1543. ) in
  1544. let g = lookup_alloc ctx.cglobals t in
  1545. g, Array.of_list fields
  1546. ) in
  1547. let g, _ = DynArray.get ctx.cconstants.arr cidx in
  1548. g
  1549. and make_string ctx s p =
  1550. let r = alloc_tmp ctx ctx.tstring in
  1551. op ctx (OGetGlobal (r, make_const ctx (CString s) p));
  1552. r
  1553. and get_enum_index ctx v =
  1554. let r = alloc_tmp ctx HI32 in
  1555. let re = eval_expr ctx v in
  1556. op ctx (ONullCheck re);
  1557. op ctx (OEnumIndex (r,re));
  1558. r
  1559. and eval_var ctx v =
  1560. match captured_index ctx v with
  1561. | None -> alloc_var ctx v false
  1562. | Some idx ->
  1563. let r = alloc_tmp ctx (to_type ctx v.v_type) in
  1564. op ctx (OEnumField (r,ctx.m.mcaptreg,0,idx));
  1565. r
  1566. and eval_expr ctx e =
  1567. set_curpos ctx e.epos;
  1568. match e.eexpr with
  1569. | TConst c ->
  1570. (match c with
  1571. | TInt i ->
  1572. let r = alloc_tmp ctx HI32 in
  1573. op ctx (OInt (r,alloc_i32 ctx i));
  1574. r
  1575. | TFloat f ->
  1576. let r = alloc_tmp ctx HF64 in
  1577. op ctx (OFloat (r,alloc_float ctx (float_of_string f)));
  1578. r
  1579. | TBool b ->
  1580. let r = alloc_tmp ctx HBool in
  1581. op ctx (OBool (r,b));
  1582. r
  1583. | TString s ->
  1584. make_string ctx s e.epos
  1585. | TThis | TSuper ->
  1586. 0 (* first reg *)
  1587. | TNull ->
  1588. let r = alloc_tmp ctx (to_type ctx e.etype) in
  1589. op ctx (ONull r);
  1590. r)
  1591. | TVar (v,e) ->
  1592. (match e with
  1593. | None ->
  1594. if captured_index ctx v = None then decl_var ctx v
  1595. | Some e ->
  1596. let ri = eval_to ctx e (to_type ctx v.v_type) in
  1597. match captured_index ctx v with
  1598. | None ->
  1599. let r = alloc_var ctx v true in
  1600. push_op ctx (OMov (r,ri));
  1601. add_assign ctx v;
  1602. | Some idx ->
  1603. op ctx (OSetEnumField (ctx.m.mcaptreg, idx, ri));
  1604. );
  1605. alloc_tmp ctx HVoid
  1606. | TLocal v ->
  1607. cast_to ctx (match captured_index ctx v with
  1608. | None ->
  1609. (* we need to make a copy for cases such as (a - a++) *)
  1610. let r = alloc_var ctx v false in
  1611. let r2 = alloc_tmp ctx (rtype ctx r) in
  1612. op ctx (OMov (r2, r));
  1613. r2
  1614. | Some idx ->
  1615. let r = alloc_tmp ctx (to_type ctx v.v_type) in
  1616. op ctx (OEnumField (r, ctx.m.mcaptreg, 0, idx));
  1617. r) (to_type ctx e.etype) e.epos
  1618. | TReturn None ->
  1619. before_return ctx;
  1620. let r = alloc_tmp ctx HVoid in
  1621. op ctx (ORet r);
  1622. alloc_tmp ctx HDyn
  1623. | TReturn (Some e) ->
  1624. let r = eval_to ctx e ctx.m.mret in
  1625. before_return ctx;
  1626. op ctx (ORet r);
  1627. alloc_tmp ctx HDyn
  1628. | TParenthesis e ->
  1629. eval_expr ctx e
  1630. | TBlock el ->
  1631. let rec loop = function
  1632. | [e] -> eval_expr ctx e
  1633. | [] -> alloc_tmp ctx HVoid
  1634. | e :: l ->
  1635. ignore(eval_expr ctx e);
  1636. loop l
  1637. in
  1638. let old = ctx.m.mdeclared in
  1639. ctx.m.mdeclared <- [];
  1640. let r = loop el in
  1641. List.iter (fun vid ->
  1642. let r = try Hashtbl.find ctx.m.mvars vid with Not_found -> -1 in
  1643. if r >= 0 then begin
  1644. Hashtbl.remove ctx.m.mvars vid;
  1645. free ctx r;
  1646. end
  1647. ) ctx.m.mdeclared;
  1648. ctx.m.mdeclared <- old;
  1649. r
  1650. | TCall ({ eexpr = TConst TSuper } as s, el) ->
  1651. (match follow s.etype with
  1652. | TInst (csup,_) ->
  1653. (match csup.cl_constructor with
  1654. | None -> die "" __LOC__
  1655. | Some f ->
  1656. let r = alloc_tmp ctx HVoid in
  1657. let el = eval_args ctx el (to_type ctx f.cf_type) e.epos in
  1658. op ctx (OCallN (r, alloc_fid ctx csup f, 0 :: el));
  1659. r
  1660. )
  1661. | _ -> die "" __LOC__);
  1662. | TCall ({ eexpr = TIdent s }, el) when s.[0] = '$' ->
  1663. let invalid() = abort "Invalid native call" e.epos in
  1664. (match s, el with
  1665. | "$new", [{ eexpr = TTypeExpr (TClassDecl _) }] ->
  1666. (match follow e.etype with
  1667. | TInst (c,pl) ->
  1668. let r = alloc_tmp ctx (class_type ctx c pl false) in
  1669. op ctx (ONew r);
  1670. r
  1671. | _ ->
  1672. invalid())
  1673. | "$int", [{ eexpr = TBinop (OpDiv, e1, e2) }] when is_int (to_type ctx e1.etype) && is_int (to_type ctx e2.etype) ->
  1674. let tmp = alloc_tmp ctx HI32 in
  1675. let r1 = eval_to ctx e1 HI32 in
  1676. hold ctx r1;
  1677. let r2 = eval_to ctx e2 HI32 in
  1678. free ctx r1;
  1679. op ctx (if unsigned_op e1 e2 then OUDiv (tmp,r1,r2) else OSDiv (tmp, r1, r2));
  1680. tmp
  1681. | "$int", [e] ->
  1682. let tmp = alloc_tmp ctx HI32 in
  1683. op ctx (OToInt (tmp, eval_expr ctx e));
  1684. tmp
  1685. | "$bsetui8", [b;pos;v] ->
  1686. let b = eval_to ctx b HBytes in
  1687. hold ctx b;
  1688. let pos = eval_to ctx pos HI32 in
  1689. hold ctx pos;
  1690. let r = eval_to ctx v HI32 in
  1691. free ctx pos;
  1692. free ctx b;
  1693. op ctx (OSetUI8 (b, pos, r));
  1694. r
  1695. | "$bsetui16", [b;pos;v] ->
  1696. let b = eval_to ctx b HBytes in
  1697. hold ctx b;
  1698. let pos = eval_to ctx pos HI32 in
  1699. hold ctx pos;
  1700. let r = eval_to ctx v HI32 in
  1701. free ctx pos;
  1702. free ctx b;
  1703. op ctx (OSetUI16 (b, pos, r));
  1704. r
  1705. | "$bseti32", [b;pos;v] ->
  1706. let b = eval_to ctx b HBytes in
  1707. hold ctx b;
  1708. let pos = eval_to ctx pos HI32 in
  1709. hold ctx pos;
  1710. let r = eval_to ctx v HI32 in
  1711. free ctx pos;
  1712. free ctx b;
  1713. op ctx (OSetMem (b, pos, r));
  1714. r
  1715. | "$bseti64", [b;pos;v] ->
  1716. let b = eval_to ctx b HBytes in
  1717. hold ctx b;
  1718. let pos = eval_to ctx pos HI32 in
  1719. hold ctx pos;
  1720. let r = eval_to ctx v HI64 in
  1721. free ctx pos;
  1722. free ctx b;
  1723. op ctx (OSetMem (b, pos, r));
  1724. r
  1725. | "$bsetf32", [b;pos;v] ->
  1726. let b = eval_to ctx b HBytes in
  1727. hold ctx b;
  1728. let pos = eval_to ctx pos HI32 in
  1729. hold ctx pos;
  1730. let r = eval_to ctx v HF32 in
  1731. free ctx pos;
  1732. free ctx b;
  1733. op ctx (OSetMem (b, pos, r));
  1734. r
  1735. | "$bsetf64", [b;pos;v] ->
  1736. let b = eval_to ctx b HBytes in
  1737. hold ctx b;
  1738. let pos = eval_to ctx pos HI32 in
  1739. hold ctx pos;
  1740. let r = eval_to ctx v HF64 in
  1741. free ctx pos;
  1742. free ctx b;
  1743. op ctx (OSetMem (b, pos, r));
  1744. r
  1745. | "$bytes_sizebits", [eb] ->
  1746. (match follow eb.etype with
  1747. | TAbstract({a_path = ["hl"],"BytesAccess"},[t]) ->
  1748. reg_int ctx (match to_type ctx t with
  1749. | HUI8 -> 0
  1750. | HUI16 -> 1
  1751. | HI32 | HF32 -> 2
  1752. | HI64 | HF64 -> 3
  1753. | t -> abort ("Unsupported basic type " ^ tstr t) e.epos)
  1754. | _ ->
  1755. abort "Invalid BytesAccess" eb.epos);
  1756. | "$bytes_nullvalue", [eb] ->
  1757. (match follow eb.etype with
  1758. | TAbstract({a_path = ["hl"],"BytesAccess"},[t]) ->
  1759. let t = to_type ctx t in
  1760. let r = alloc_tmp ctx t in
  1761. (match t with
  1762. | HUI8 | HUI16 | HI32 | HI64 ->
  1763. op ctx (OInt (r,alloc_i32 ctx 0l))
  1764. | HF32 | HF64 ->
  1765. op ctx (OFloat (r, alloc_float ctx 0.))
  1766. | t ->
  1767. abort ("Unsupported basic type " ^ tstr t) e.epos);
  1768. r
  1769. | _ ->
  1770. abort "Invalid BytesAccess" eb.epos);
  1771. | "$bget", [eb;pos] ->
  1772. (match follow eb.etype with
  1773. | TAbstract({a_path = ["hl"],"BytesAccess"},[t]) ->
  1774. let b = eval_to ctx eb HBytes in
  1775. hold ctx b;
  1776. let pos = eval_to ctx pos HI32 in
  1777. free ctx b;
  1778. let t = to_type ctx t in
  1779. (match t with
  1780. | HUI8 ->
  1781. let r = alloc_tmp ctx HI32 in
  1782. op ctx (OGetUI8 (r, b, pos));
  1783. r
  1784. | HUI16 ->
  1785. let r = alloc_tmp ctx HI32 in
  1786. op ctx (OGetUI16 (r, b, shl ctx pos 1));
  1787. r
  1788. | HI32 ->
  1789. let r = alloc_tmp ctx HI32 in
  1790. op ctx (OGetMem (r, b, shl ctx pos 2));
  1791. r
  1792. | HI64 ->
  1793. let r = alloc_tmp ctx HI64 in
  1794. op ctx (OGetMem (r, b, shl ctx pos 3));
  1795. r
  1796. | HF32 ->
  1797. let r = alloc_tmp ctx HF32 in
  1798. op ctx (OGetMem (r, b, shl ctx pos 2));
  1799. r
  1800. | HF64 ->
  1801. let r = alloc_tmp ctx HF64 in
  1802. op ctx (OGetMem (r, b, shl ctx pos 3));
  1803. r
  1804. | _ ->
  1805. abort ("Unsupported basic type " ^ tstr t) e.epos)
  1806. | _ ->
  1807. abort "Invalid BytesAccess" eb.epos);
  1808. | "$bset", [eb;pos;value] ->
  1809. (match follow eb.etype with
  1810. | TAbstract({a_path = ["hl"],"BytesAccess"},[t]) ->
  1811. let b = eval_to ctx eb HBytes in
  1812. hold ctx b;
  1813. let pos = eval_to ctx pos HI32 in
  1814. hold ctx pos;
  1815. let t = to_type ctx t in
  1816. let v = (match t with
  1817. | HUI8 ->
  1818. let v = eval_to ctx value HI32 in
  1819. op ctx (OSetUI8 (b, pos, v));
  1820. v
  1821. | HUI16 ->
  1822. let v = eval_to ctx value HI32 in
  1823. hold ctx v;
  1824. op ctx (OSetUI16 (b, shl ctx pos 1, v));
  1825. free ctx v;
  1826. v
  1827. | HI32 ->
  1828. let v = eval_to ctx value HI32 in
  1829. hold ctx v;
  1830. op ctx (OSetMem (b, shl ctx pos 2, v));
  1831. free ctx v;
  1832. v
  1833. | HI64 ->
  1834. let v = eval_to ctx value HI64 in
  1835. hold ctx v;
  1836. op ctx (OSetMem (b, shl ctx pos 3, v));
  1837. free ctx v;
  1838. v
  1839. | HF32 ->
  1840. let v = eval_to ctx value HF32 in
  1841. hold ctx v;
  1842. op ctx (OSetMem (b, shl ctx pos 2, v));
  1843. free ctx v;
  1844. v
  1845. | HF64 ->
  1846. let v = eval_to ctx value HF64 in
  1847. hold ctx v;
  1848. op ctx (OSetMem (b, shl ctx pos 3, v));
  1849. free ctx v;
  1850. v
  1851. | _ ->
  1852. abort ("Unsupported basic type " ^ tstr t) e.epos
  1853. ) in
  1854. free ctx b;
  1855. free ctx pos;
  1856. v
  1857. | _ ->
  1858. abort "Invalid BytesAccess" eb.epos);
  1859. | "$bgetui8", [b;pos] ->
  1860. let b = eval_to ctx b HBytes in
  1861. hold ctx b;
  1862. let pos = eval_to ctx pos HI32 in
  1863. free ctx b;
  1864. let r = alloc_tmp ctx HI32 in
  1865. op ctx (OGetUI8 (r, b, pos));
  1866. r
  1867. | "$bgetui16", [b;pos] ->
  1868. let b = eval_to ctx b HBytes in
  1869. hold ctx b;
  1870. let pos = eval_to ctx pos HI32 in
  1871. free ctx b;
  1872. let r = alloc_tmp ctx HI32 in
  1873. op ctx (OGetUI16 (r, b, pos));
  1874. r
  1875. | "$bgeti32", [b;pos] ->
  1876. let b = eval_to ctx b HBytes in
  1877. hold ctx b;
  1878. let pos = eval_to ctx pos HI32 in
  1879. free ctx b;
  1880. let r = alloc_tmp ctx HI32 in
  1881. op ctx (OGetMem (r, b, pos));
  1882. r
  1883. | "$bgeti64", [b;pos] ->
  1884. let b = eval_to ctx b HBytes in
  1885. hold ctx b;
  1886. let pos = eval_to ctx pos HI32 in
  1887. free ctx b;
  1888. let r = alloc_tmp ctx HI64 in
  1889. op ctx (OGetMem (r, b, pos));
  1890. r
  1891. | "$bgetf32", [b;pos] ->
  1892. let b = eval_to ctx b HBytes in
  1893. hold ctx b;
  1894. let pos = eval_to ctx pos HI32 in
  1895. free ctx b;
  1896. let r = alloc_tmp ctx HF32 in
  1897. op ctx (OGetMem (r, b, pos));
  1898. r
  1899. | "$bgetf64", [b;pos] ->
  1900. let b = eval_to ctx b HBytes in
  1901. hold ctx b;
  1902. let pos = eval_to ctx pos HI32 in
  1903. free ctx b;
  1904. let r = alloc_tmp ctx HF64 in
  1905. op ctx (OGetMem (r, b, pos));
  1906. r
  1907. | "$asize", [e] ->
  1908. let r = alloc_tmp ctx HI32 in
  1909. (match follow e.etype with
  1910. | TInst ({cl_path=["hl"],"Abstract"},[TInst({ cl_kind = KExpr (EConst (String("hl_carray",_)),_) },_)]) ->
  1911. let arr = eval_expr ctx e in
  1912. op ctx (ONullCheck arr);
  1913. op ctx (OArraySize (r, arr))
  1914. | TAbstract ({ a_path = ["hl"],"NativeArray" },[t]) ->
  1915. op ctx (OArraySize (r, eval_to ctx e (HArray (to_type ctx t))))
  1916. | _ ->
  1917. invalid());
  1918. r
  1919. | "$aalloc", [esize] ->
  1920. let et = (match follow e.etype with TAbstract ({ a_path = ["hl"],"NativeArray" },[t]) -> to_type ctx t | _ -> invalid()) in
  1921. let size = eval_to ctx esize HI32 in
  1922. alloc_array ctx size et
  1923. | "$aget", [a; pos] ->
  1924. (*
  1925. read/write on arrays are unsafe : the type of NativeArray needs to be correcly set.
  1926. *)
  1927. let at = (match follow a.etype with TAbstract ({ a_path = ["hl"],"NativeArray" },[t]) -> to_type ctx t | _ -> invalid()) in
  1928. let arr = eval_to ctx a (HArray at) in
  1929. hold ctx arr;
  1930. let pos = eval_to ctx pos HI32 in
  1931. free ctx arr;
  1932. let r = if is_array_type at then alloc_tmp ctx HDyn else alloc_tmp ctx at in
  1933. op ctx (OGetArray (r, arr, pos));
  1934. cast_to ctx r (to_type ctx e.etype) e.epos
  1935. | "$aset", [a; pos; value] ->
  1936. let et = (match follow a.etype with TAbstract ({ a_path = ["hl"],"NativeArray" },[t]) -> to_type ctx t | _ -> invalid()) in
  1937. let arr = eval_to ctx a (HArray et) in
  1938. hold ctx arr;
  1939. let pos = eval_to ctx pos HI32 in
  1940. hold ctx pos;
  1941. let r = eval_to ctx value et in
  1942. free ctx pos;
  1943. free ctx arr;
  1944. op ctx (OSetArray (arr, pos, r));
  1945. r
  1946. | "$abytes", [a] ->
  1947. (match follow a.etype with
  1948. | TInst ({ cl_path = [], "Array" },[t]) when is_number (to_type ctx t) ->
  1949. let a = eval_expr ctx a in
  1950. let r = alloc_tmp ctx HBytes in
  1951. op ctx (ONullCheck a);
  1952. op ctx (OField (r,a,1));
  1953. r
  1954. | t ->
  1955. abort ("Invalid array type " ^ s_type (print_context()) t) a.epos)
  1956. | "$ref", [v] ->
  1957. (match v.eexpr with
  1958. | TLocal v ->
  1959. let r = alloc_tmp ctx (to_type ctx e.etype) in
  1960. let rv = (match rtype ctx r with HRef t -> alloc_var ctx v false | _ -> invalid()) in
  1961. hold ctx rv; (* infinite hold *)
  1962. op ctx (ORef (r,rv));
  1963. r
  1964. | _ ->
  1965. abort "Ref should be a local variable" v.epos)
  1966. | "$setref", [e1;e2] ->
  1967. let rec loop e = match e.eexpr with
  1968. | TParenthesis e1 | TMeta(_,e1) | TCast(e1,None) -> loop e1
  1969. | TLocal v -> v
  1970. | _ -> invalid()
  1971. in
  1972. let v = loop e1 in
  1973. let r = alloc_var ctx v false in
  1974. let rv = eval_to ctx e2 (match rtype ctx r with HRef t -> t | _ -> invalid()) in
  1975. op ctx (OSetref (r,rv));
  1976. r
  1977. | "$unref", [e1] ->
  1978. let rec loop e = match e.eexpr with
  1979. | TParenthesis e1 | TMeta(_,e1) | TCast(e1,None) -> loop e1
  1980. | TLocal v -> v
  1981. | _ -> invalid()
  1982. in
  1983. let v = loop e1 in
  1984. let r = alloc_var ctx v false in
  1985. let out = alloc_tmp ctx (match rtype ctx r with HRef t -> t | _ -> invalid()) in
  1986. op ctx (OUnref (out,r));
  1987. out
  1988. | "$refdata", [e1] ->
  1989. let v = eval_expr ctx e1 in
  1990. let r = alloc_tmp ctx (match to_type ctx e.etype with HRef _ as t -> t | _ -> invalid()) in
  1991. op ctx (ORefData (r,v));
  1992. r
  1993. | "$refoffset", [r;e1] ->
  1994. let r = eval_expr ctx r in
  1995. let e = eval_to ctx e1 HI32 in
  1996. let r2 = alloc_tmp ctx (match rtype ctx r with HRef _ as t -> t | _ -> invalid()) in
  1997. op ctx (ORefOffset (r2,r,e));
  1998. r2
  1999. | "$ttype", [v] ->
  2000. let r = alloc_tmp ctx HType in
  2001. op ctx (OType (r,to_type ctx v.etype));
  2002. r
  2003. | "$tdyntype", [v] ->
  2004. let r = alloc_tmp ctx HType in
  2005. op ctx (OGetType (r,eval_to ctx v HDyn));
  2006. r
  2007. | "$tkind", [v] ->
  2008. let r = alloc_tmp ctx HI32 in
  2009. op ctx (OGetTID (r,eval_to ctx v HType));
  2010. r
  2011. | "$resources", [] ->
  2012. let tdef = (try List.find (fun t -> (t_infos t).mt_path = (["haxe";"_Resource"],"ResourceContent")) ctx.com.types with Not_found -> die "" __LOC__) in
  2013. let t = class_type ctx (match tdef with TClassDecl c -> c | _ -> die "" __LOC__) [] false in
  2014. let res = Hashtbl.fold (fun k v acc -> (k,v) :: acc) ctx.com.resources [] in
  2015. let size = reg_int ctx (List.length res) in
  2016. let arr = alloc_array ctx size HBytes in
  2017. let ro = alloc_tmp ctx t in
  2018. let rb = alloc_tmp ctx HBytes in
  2019. let ridx = reg_int ctx 0 in
  2020. hold ctx ridx;
  2021. let has_len = (match t with HObj p -> PMap.mem "dataLen" p.pindex | _ -> die "" __LOC__) in
  2022. list_iteri (fun i (k,v) ->
  2023. op ctx (ONew ro);
  2024. op ctx (OString (rb,alloc_string ctx k));
  2025. op ctx (OSetField (ro,0,rb));
  2026. (* fix for Resource.getString *)
  2027. let str = try ignore(String.index v '\x00'); v with Not_found -> v ^ "\x00" in
  2028. op ctx (OBytes (rb,alloc_bytes ctx (Bytes.of_string str)));
  2029. op ctx (OSetField (ro,1,rb));
  2030. if has_len then op ctx (OSetField (ro,2,reg_int ctx (String.length v)));
  2031. op ctx (OSetArray (arr,ridx,ro));
  2032. op ctx (OIncr ridx);
  2033. ) res;
  2034. free ctx ridx;
  2035. arr
  2036. | "$rethrow", [v] ->
  2037. let r = alloc_tmp ctx HVoid in
  2038. op ctx (ORethrow (eval_to ctx v HDyn));
  2039. r
  2040. | "$allTypes", [] ->
  2041. let r = alloc_tmp ctx (to_type ctx e.etype) in
  2042. op ctx (OGetGlobal (r, alloc_global ctx "__types__" (rtype ctx r)));
  2043. r
  2044. | "$allTypes", [v] ->
  2045. let v = eval_expr ctx v in
  2046. op ctx (OSetGlobal (alloc_global ctx "__types__" (rtype ctx v), v));
  2047. v
  2048. | "$hash", [v] ->
  2049. (match v.eexpr with
  2050. | TConst (TString str) ->
  2051. let r = alloc_tmp ctx HI32 in
  2052. op ctx (OInt (r,alloc_i32 ctx (hl_hash str)));
  2053. r
  2054. | _ -> abort "Constant string required" v.epos)
  2055. | "$enumIndex", [v] ->
  2056. get_enum_index ctx v
  2057. | "$__mk_pos__", [{ eexpr = TConst (TString file) };min;max] ->
  2058. (* macros only - generated by reification *)
  2059. let rt = HAbstract ("macro_pos",alloc_string ctx "macro_pos") in
  2060. let r = alloc_tmp ctx rt in
  2061. let rfile = alloc_tmp ctx HBytes in
  2062. op ctx (OBytes (rfile, alloc_bytes ctx (Bytes.of_string file)));
  2063. hold ctx rfile;
  2064. let min = eval_expr ctx min in hold ctx min;
  2065. let max = eval_expr ctx max in
  2066. op ctx (OCall3 (r,alloc_std ctx "make_macro_pos" [HBytes;HI32;HI32] rt,rfile,min,max));
  2067. free ctx rfile;
  2068. free ctx min;
  2069. r
  2070. | "$prefetch", [value; mode] ->
  2071. let mode = (match get_const mode with
  2072. | TInt m -> Int32.to_int m
  2073. | _ -> abort "Constant mode required" e.epos
  2074. ) in
  2075. (match get_access ctx value with
  2076. | AInstanceField (f, index) -> op ctx (OPrefetch (eval_expr ctx f, index + 1, mode))
  2077. | _ -> op ctx (OPrefetch (eval_expr ctx value, 0, mode)));
  2078. alloc_tmp ctx HVoid
  2079. | "$unsafecast", [value] ->
  2080. let r = alloc_tmp ctx (to_type ctx e.etype) in
  2081. op ctx (OUnsafeCast (r, eval_expr ctx value));
  2082. r
  2083. | "$asm", [mode; value] ->
  2084. let mode = (match get_const mode with
  2085. | TInt m -> Int32.to_int m
  2086. | _ -> abort "Constant mode required" e.epos
  2087. ) in
  2088. let value = (match get_const value with
  2089. | TInt m -> Int32.to_int m
  2090. | _ -> abort "Constant value required" e.epos
  2091. ) in
  2092. op ctx (OAsm (mode, value, 0));
  2093. alloc_tmp ctx HVoid
  2094. | "$asm", [mode; value; reg] ->
  2095. let mode = (match get_const mode with
  2096. | TInt m -> Int32.to_int m
  2097. | _ -> abort "Constant mode required" e.epos
  2098. ) in
  2099. let value = (match get_const value with
  2100. | TInt m -> Int32.to_int m
  2101. | _ -> abort "Constant value required" e.epos
  2102. ) in
  2103. op ctx (OAsm (mode, value, (eval_expr ctx reg) + 1));
  2104. alloc_tmp ctx HVoid
  2105. | _ ->
  2106. abort ("Unknown native call " ^ s) e.epos)
  2107. | TEnumIndex v ->
  2108. get_enum_index ctx v
  2109. | TCall ({ eexpr = TField (_,FStatic ({ cl_path = [],"Type" },{ cf_name = "enumIndex" })) },[{ eexpr = TCast(v,_) }]) when (match follow v.etype with TEnum _ -> true | _ -> false) ->
  2110. get_enum_index ctx v
  2111. | TCall ({ eexpr = TField (_,FStatic ({ cl_path = [],"Type" },{ cf_name = "enumIndex" })) },[v]) when (match follow v.etype with TEnum _ -> true | _ -> false) ->
  2112. get_enum_index ctx v
  2113. | TCall ({ eexpr = TField (ef,FStatic ({ cl_path = [],"Reflect" } as c,{ cf_name = "makeVarArgs" })) } as e1,[v]) ->
  2114. eval_expr ctx {e with eexpr = TCall({e1 with eexpr = TField(ef,FStatic(c, PMap.find "_makeVarArgs" c.cl_statics))},[v])}
  2115. | TCall ({ eexpr = TField (_,FStatic ({ cl_path = [],"Std" },{ cf_name = "instance" })) },[v;vt])
  2116. | TCall ({ eexpr = TField (_,FStatic ({ cl_path = [],"Std" },{ cf_name = "downcast" })) },[v;vt]) ->
  2117. let r = eval_expr ctx v in
  2118. hold ctx r;
  2119. let c = eval_to ctx vt (class_type ctx ctx.base_type [] false) in
  2120. hold ctx c;
  2121. let rv = alloc_tmp ctx (to_type ctx e.etype) in
  2122. let rb = alloc_tmp ctx HBool in
  2123. op ctx (OCall2 (rb, alloc_fun_path ctx (["hl"],"BaseType") "check",c,r));
  2124. let jnext = jump ctx (fun n -> OJFalse (rb,n)) in
  2125. op ctx (OMov (rv, unsafe_cast_to ~debugchk:false ctx r (to_type ctx e.etype) e.epos));
  2126. let jend = jump ctx (fun n -> OJAlways n) in
  2127. jnext();
  2128. op ctx (ONull rv);
  2129. jend();
  2130. free ctx r;
  2131. free ctx c;
  2132. rv
  2133. | TCall (ec,args) ->
  2134. let tfun = real_type ctx ec in
  2135. let el() = eval_args ctx args tfun e.epos in
  2136. let ret = alloc_tmp ctx (match tfun with HFun (_,r) -> r | _ -> HDyn) in
  2137. let def_ret = ref None in
  2138. (match get_access ctx ec with
  2139. | AStaticFun f ->
  2140. (match el() with
  2141. | [] -> op ctx (OCall0 (ret, f))
  2142. | [a] -> op ctx (OCall1 (ret, f, a))
  2143. | [a;b] -> op ctx (OCall2 (ret, f, a, b))
  2144. | [a;b;c] -> op ctx (OCall3 (ret, f, a, b, c))
  2145. | [a;b;c;d] -> op ctx (OCall4 (ret, f, a, b, c, d))
  2146. | el -> op ctx (OCallN (ret, f, el)));
  2147. | AInstanceFun (ethis, f) ->
  2148. let r = eval_null_check ctx ethis in
  2149. hold ctx r;
  2150. let el = r :: el() in
  2151. free ctx r;
  2152. (match el with
  2153. | [a] -> op ctx (OCall1 (ret, f, a))
  2154. | [a;b] -> op ctx (OCall2 (ret, f, a, b))
  2155. | [a;b;c] -> op ctx (OCall3 (ret, f, a, b, c))
  2156. | [a;b;c;d] -> op ctx (OCall4 (ret, f, a, b, c, d))
  2157. | _ -> op ctx (OCallN (ret, f, el)));
  2158. | AInstanceProto ({ eexpr = TConst TThis }, fid) ->
  2159. op ctx (OCallThis (ret, fid, el()))
  2160. | AInstanceProto (ethis, fid) | AVirtualMethod (ethis, fid) ->
  2161. let r = eval_null_check ctx ethis in
  2162. hold ctx r;
  2163. let el = r :: el() in
  2164. free ctx r;
  2165. op ctx (OCallMethod (ret, fid, el))
  2166. | AEnum (_,index) ->
  2167. op ctx (OMakeEnum (ret, index, el()))
  2168. | AArray (a,t,idx) ->
  2169. let r = array_read ctx a t idx ec.epos in
  2170. hold ctx r;
  2171. op ctx (ONullCheck r);
  2172. op ctx (OCallClosure (ret, r, el())); (* if it's a value, it's a closure *)
  2173. free ctx r;
  2174. | _ ->
  2175. (* don't use real_type here *)
  2176. let tfun = to_type ctx ec.etype in
  2177. let r = eval_null_check ctx ec in
  2178. hold ctx r;
  2179. let el = eval_args ctx args tfun e.epos in
  2180. free ctx r;
  2181. let ret = alloc_tmp ctx (match tfun with HFun (_,r) -> r | _ -> HDyn) in
  2182. op ctx (OCallClosure (ret, r, el)); (* if it's a value, it's a closure *)
  2183. def_ret := Some (cast_to ~force:true ctx ret (to_type ctx e.etype) e.epos);
  2184. );
  2185. (match !def_ret with
  2186. | None ->
  2187. let rt = to_type ctx e.etype in
  2188. let is_valid_method t =
  2189. match follow t with
  2190. | TFun (_,rt) ->
  2191. (match follow rt with
  2192. | TInst({ cl_kind = KTypeParameter ttp },_) ->
  2193. (* don't allow if we have a constraint virtual, see hxbit.Serializer.getRef *)
  2194. not (List.exists (fun t -> match to_type ctx t with HVirtual _ -> true | _ -> false) (get_constraints ttp))
  2195. | _ -> false)
  2196. | _ ->
  2197. false
  2198. in
  2199. (match ec.eexpr with
  2200. | TField (_, FInstance(_,_,{ cf_kind = Method (MethNormal|MethInline); cf_type = t })) when is_valid_method t ->
  2201. (* let's trust the compiler when it comes to casting the return value from a type parameter *)
  2202. unsafe_cast_to ctx ret rt e.epos
  2203. | _ ->
  2204. cast_to ~force:true ctx ret rt e.epos)
  2205. | Some r ->
  2206. r)
  2207. | TField (ec,FInstance({ cl_path = [],"Array" },[t],{ cf_name = "length" })) when to_type ctx t = HDyn ->
  2208. let r = alloc_tmp ctx HI32 in
  2209. op ctx (OCall1 (r,alloc_fun_path ctx (["hl";"types"],"ArrayDyn") "get_length", eval_null_check ctx ec));
  2210. r
  2211. | TField (ec,a) ->
  2212. let r = alloc_tmp ctx (to_type ctx (field_type ctx a e.epos)) in
  2213. (match get_access ctx e with
  2214. | AGlobal g ->
  2215. op ctx (OGetGlobal (r,g));
  2216. | AStaticVar (g,t,fid) ->
  2217. let o = alloc_tmp ctx t in
  2218. op ctx (OGetGlobal (o,g));
  2219. op ctx (OField (r,o,fid));
  2220. | AStaticFun f ->
  2221. op ctx (OStaticClosure (r,f));
  2222. | AInstanceFun (ethis, f) ->
  2223. op ctx (OInstanceClosure (r, f, eval_null_check ctx ethis))
  2224. | AInstanceField (ethis,fid) ->
  2225. let robj = eval_null_check ctx ethis in
  2226. op ctx (match ethis.eexpr with TConst TThis -> OGetThis (r,fid) | _ -> OField (r,robj,fid));
  2227. | AInstanceProto (ethis,fid) | AVirtualMethod (ethis, fid) ->
  2228. let robj = eval_null_check ctx ethis in
  2229. (match rtype ctx robj with
  2230. | HObj _ ->
  2231. op ctx (OVirtualClosure (r,robj,fid))
  2232. | HVirtual vp ->
  2233. let _, sid, _ = vp.vfields.(fid) in
  2234. op ctx (ODynGet (r,robj, sid))
  2235. | _ ->
  2236. die "" __LOC__)
  2237. | ADynamic (ethis, f) ->
  2238. let robj = eval_null_check ctx ethis in
  2239. op ctx (ODynGet (r,robj,f))
  2240. | AEnum (en,index) ->
  2241. let cur_fid = DynArray.length ctx.cfids.arr in
  2242. let name = List.nth en.e_names index in
  2243. let fid = alloc_fun_path ctx en.e_path name in
  2244. if fid = cur_fid then begin
  2245. let ef = PMap.find name en.e_constrs in
  2246. let eargs, et = (match follow ef.ef_type with TFun (args,ret) -> args, ret | _ -> die "" __LOC__) in
  2247. let ct = ctx.com.basic in
  2248. let p = ef.ef_pos in
  2249. let eargs = List.map (fun (n,o,t) -> Type.alloc_var VGenerated n t en.e_pos, if o then Some (mk (TConst TNull) t_dynamic null_pos) else None) eargs in
  2250. let ecall = mk (TCall (e,List.map (fun (v,_) -> mk (TLocal v) v.v_type p) eargs)) et p in
  2251. let f = {
  2252. tf_args = eargs;
  2253. tf_type = et;
  2254. tf_expr = mk (TReturn (Some ecall)) ct.tvoid p;
  2255. } in
  2256. ignore(make_fun ctx ("","") fid f None None);
  2257. end;
  2258. op ctx (OStaticClosure (r,fid));
  2259. | ANone | ALocal _ | AArray _ | ACaptured _ | ACArray _ ->
  2260. abort "Invalid access" e.epos);
  2261. let to_t = to_type ctx e.etype in
  2262. (match to_t with
  2263. | HFun _ -> cast_to ctx r to_t e.epos
  2264. | _ -> unsafe_cast_to ctx r to_t e.epos)
  2265. | TObjectDecl fl ->
  2266. (match to_type ctx e.etype with
  2267. | HVirtual vp as t when Array.length vp.vfields = List.length fl && not (List.exists (fun ((s,_,_),e) -> s = "toString" && is_to_string e.etype) fl) ->
  2268. let r = alloc_tmp ctx t in
  2269. op ctx (ONew r);
  2270. hold ctx r;
  2271. List.iter (fun ((s,_,_),ev) ->
  2272. let fidx = (try PMap.find s vp.vindex with Not_found -> die "" __LOC__) in
  2273. let _, _, ft = vp.vfields.(fidx) in
  2274. let v = eval_to ctx ev ft in
  2275. op ctx (OSetField (r,fidx,v));
  2276. ) fl;
  2277. free ctx r;
  2278. r
  2279. | _ ->
  2280. let r = alloc_tmp ctx HDynObj in
  2281. op ctx (ONew r);
  2282. hold ctx r;
  2283. let a = (match follow e.etype with TAnon a -> Some a | t -> if t == t_dynamic then None else die "" __LOC__) in
  2284. List.iter (fun ((s,_,_),ev) ->
  2285. let ft = (try (match a with None -> raise Not_found | Some a -> PMap.find s a.a_fields).cf_type with Not_found -> ev.etype) in
  2286. let v = eval_to ctx ev (to_type ctx ft) in
  2287. op ctx (ODynSet (r,alloc_string ctx s,v));
  2288. if s = "toString" && is_to_string ev.etype then begin
  2289. let f = alloc_tmp ctx (HFun ([],HBytes)) in
  2290. op ctx (OInstanceClosure (f, alloc_fun_path ctx ([],"String") "call_toString", r));
  2291. op ctx (ODynSet (r,alloc_string ctx "__string",f));
  2292. end;
  2293. ) fl;
  2294. free ctx r;
  2295. cast_to ctx r (to_type ctx e.etype) e.epos)
  2296. | TNew (c,pl,el) ->
  2297. let c = resolve_class ctx c pl false in
  2298. let r = alloc_tmp ctx (class_type ctx c pl false) in
  2299. op ctx (ONew r);
  2300. hold ctx r;
  2301. (match c.cl_constructor with
  2302. | None -> if c.cl_implements <> [] then die "" __LOC__
  2303. | Some { cf_expr = None } -> abort (s_type_path c.cl_path ^ " does not have a constructor") e.epos
  2304. | Some ({ cf_expr = Some cexpr } as constr) ->
  2305. let rl = eval_args ctx el (to_type ctx cexpr.etype) e.epos in
  2306. let ret = alloc_tmp ctx HVoid in
  2307. let g = alloc_fid ctx c constr in
  2308. op ctx (match rl with
  2309. | [] -> OCall1 (ret,g,r)
  2310. | [a] -> OCall2 (ret,g,r,a)
  2311. | [a;b] -> OCall3 (ret,g,r,a,b)
  2312. | [a;b;c] -> OCall4 (ret,g,r,a,b,c)
  2313. | _ -> OCallN (ret,g,r :: rl));
  2314. );
  2315. free ctx r;
  2316. r
  2317. | TIf (cond,eif,eelse) ->
  2318. let t = to_type ctx e.etype in
  2319. let out = alloc_tmp ctx t in
  2320. let j = jump_expr ctx cond false in
  2321. let rif = if t = HVoid then eval_expr ctx eif else eval_to ctx eif t in
  2322. set_curpos ctx (max_pos eif);
  2323. if t <> HVoid then op ctx (OMov (out,rif));
  2324. (match eelse with
  2325. | None -> j()
  2326. | Some e ->
  2327. let jexit = jump ctx (fun i -> OJAlways i) in
  2328. j();
  2329. if t = HVoid then ignore(eval_expr ctx e) else op ctx (OMov (out,eval_to ctx e t));
  2330. jexit());
  2331. out
  2332. | TBinop (bop, e1, e2) ->
  2333. let arithbinop r a b =
  2334. let rec loop bop =
  2335. match bop with
  2336. | OpAdd ->
  2337. (match rtype ctx r with
  2338. | HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 ->
  2339. op ctx (OAdd (r,a,b))
  2340. | HObj { pname = "String" } ->
  2341. op ctx (OCall2 (r,alloc_fun_path ctx ([],"String") "__add__",to_string ctx a e1.epos,to_string ctx b e2.epos))
  2342. | HDyn ->
  2343. op ctx (OCall2 (r,alloc_fun_path ctx ([],"Std") "__add__",a,b))
  2344. | t ->
  2345. abort ("Cannot add " ^ tstr t) e.epos)
  2346. | OpSub | OpMult | OpMod | OpDiv ->
  2347. (match rtype ctx r with
  2348. | HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 ->
  2349. (match bop with
  2350. | OpSub -> op ctx (OSub (r,a,b))
  2351. | OpMult -> op ctx (OMul (r,a,b))
  2352. | OpMod -> op ctx (if unsigned e1.etype then OUMod (r,a,b) else OSMod (r,a,b))
  2353. | OpDiv -> op ctx (OSDiv (r,a,b)) (* don't use UDiv since both operands are float already *)
  2354. | _ -> die "" __LOC__)
  2355. | HDyn ->
  2356. op ctx (OCall3 (r, alloc_std ctx "dyn_op" [HI32;HDyn;HDyn] HDyn, reg_int ctx (match bop with OpSub -> 1 | OpMult -> 2 | OpMod -> 3 | OpDiv -> 4 | _ -> die "" __LOC__), a, b))
  2357. | _ ->
  2358. die "" __LOC__)
  2359. | OpShl | OpShr | OpUShr | OpAnd | OpOr | OpXor ->
  2360. (match rtype ctx r with
  2361. | HUI8 | HUI16 | HI32 | HI64 ->
  2362. (match bop with
  2363. | OpShl -> op ctx (OShl (r,a,b))
  2364. | OpShr -> op ctx (if unsigned e1.etype then OUShr (r,a,b) else OSShr (r,a,b))
  2365. | OpUShr -> op ctx (OUShr (r,a,b))
  2366. | OpAnd -> op ctx (OAnd (r,a,b))
  2367. | OpOr -> op ctx (OOr (r,a,b))
  2368. | OpXor -> op ctx (OXor (r,a,b))
  2369. | _ -> ())
  2370. | HDyn ->
  2371. op ctx (OCall3 (r, alloc_std ctx "dyn_op" [HI32;HDyn;HDyn] HDyn, reg_int ctx (match bop with OpShl -> 5 | OpShr -> 6 | OpUShr -> 7 | OpAnd -> 8 | OpOr -> 9 | OpXor -> 10 | _ -> die "" __LOC__), a, b))
  2372. | _ ->
  2373. die "" __LOC__)
  2374. | OpAssignOp bop ->
  2375. loop bop
  2376. | _ ->
  2377. die "" __LOC__
  2378. in
  2379. loop bop
  2380. in
  2381. (match bop with
  2382. | OpLte | OpGt | OpGte | OpLt | OpEq | OpNotEq ->
  2383. let r = alloc_tmp ctx HBool in
  2384. let j = jump_expr ctx e false in
  2385. op ctx (OBool (r, true));
  2386. op ctx (OJAlways 1);
  2387. j();
  2388. op ctx (OBool (r, false));
  2389. r
  2390. | OpAdd | OpSub | OpMult | OpDiv | OpMod | OpShl | OpShr | OpUShr | OpAnd | OpOr | OpXor ->
  2391. let t = (match to_type ctx e.etype with HNull t -> t | t -> t) in
  2392. let conv_string = bop = OpAdd && is_string t in
  2393. let eval e =
  2394. if conv_string then
  2395. let r = eval_expr ctx e in
  2396. to_string ctx r e.epos
  2397. else
  2398. eval_to ctx e t
  2399. in
  2400. let r = alloc_tmp ctx t in
  2401. let a = eval e1 in
  2402. hold ctx a;
  2403. let b = eval e2 in
  2404. free ctx a;
  2405. arithbinop r a b;
  2406. r
  2407. | OpAssign ->
  2408. let value() = eval_to ctx e2 (real_type ctx e1) in
  2409. (match get_access ctx e1 with
  2410. | AGlobal g ->
  2411. let r = value() in
  2412. op ctx (OSetGlobal (g,r));
  2413. r
  2414. | AStaticVar (g,t,fid) ->
  2415. let r = value() in
  2416. hold ctx r;
  2417. let o = alloc_tmp ctx t in
  2418. free ctx r;
  2419. op ctx (OGetGlobal (o, g));
  2420. op ctx (OSetField (o, fid, r));
  2421. r
  2422. | AInstanceField ({ eexpr = TConst TThis }, fid) ->
  2423. let r = value() in
  2424. op ctx (OSetThis (fid,r));
  2425. r
  2426. | AInstanceField (ethis, fid) ->
  2427. let rthis = eval_null_check ctx ethis in
  2428. hold ctx rthis;
  2429. let r = value() in
  2430. free ctx rthis;
  2431. op ctx (OSetField (rthis, fid, r));
  2432. r
  2433. | ALocal (v,l) ->
  2434. let r = value() in
  2435. push_op ctx (OMov (l, r));
  2436. add_assign ctx v;
  2437. r
  2438. | AArray (ra,(at,vt),ridx) ->
  2439. hold ctx ra;
  2440. hold ctx ridx;
  2441. let v = cast_to ctx (value()) (match at with HUI16 | HUI8 -> HI32 | _ -> at) e.epos in
  2442. hold ctx v;
  2443. (* bounds check against length *)
  2444. (match at with
  2445. | HDyn ->
  2446. (* call setDyn() *)
  2447. op ctx (OCallMethod (alloc_tmp ctx HVoid,1,[ra;ridx;cast_to ctx v (if is_dynamic at then at else HDyn) e.epos]));
  2448. | _ ->
  2449. let len = alloc_tmp ctx HI32 in
  2450. op ctx (OField (len,ra,0)); (* length *)
  2451. let j = jump ctx (fun i -> OJULt (ridx,len,i)) in
  2452. op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx (array_class ctx at).cl_path "__expand", ra, ridx));
  2453. j();
  2454. match at with
  2455. | HI32 | HF64 | HUI16 | HF32 | HI64 ->
  2456. let b = alloc_tmp ctx HBytes in
  2457. op ctx (OField (b,ra,1));
  2458. write_mem ctx b (shl ctx ridx (type_size_bits at)) at v
  2459. | _ ->
  2460. let arr = alloc_tmp ctx (HArray vt) in
  2461. op ctx (OField (arr,ra,1));
  2462. op ctx (OSetArray (arr,ridx,cast_to ctx v (if is_dynamic at then at else HDyn) e.epos))
  2463. );
  2464. free ctx v;
  2465. free ctx ra;
  2466. free ctx ridx;
  2467. v
  2468. | ACArray (ra, _, ridx) ->
  2469. hold ctx ra;
  2470. hold ctx ridx;
  2471. let v = value() in
  2472. op ctx (OSetArray (ra,ridx,v));
  2473. free ctx ridx;
  2474. free ctx ra;
  2475. v
  2476. | ADynamic (ethis,f) ->
  2477. let obj = eval_null_check ctx ethis in
  2478. hold ctx obj;
  2479. let r = eval_expr ctx e2 in
  2480. free ctx obj;
  2481. op ctx (ODynSet (obj,f,r));
  2482. r
  2483. | ACaptured index ->
  2484. let r = value() in
  2485. op ctx (OSetEnumField (ctx.m.mcaptreg,index,r));
  2486. r
  2487. | AEnum _ | ANone | AInstanceFun _ | AInstanceProto _ | AStaticFun _ | AVirtualMethod _ ->
  2488. die "" __LOC__)
  2489. | OpBoolOr ->
  2490. let r = alloc_tmp ctx HBool in
  2491. let j = jump_expr ctx e1 true in
  2492. let j2 = jump_expr ctx e2 true in
  2493. op ctx (OBool (r,false));
  2494. let jend = jump ctx (fun b -> OJAlways b) in
  2495. j();
  2496. j2();
  2497. op ctx (OBool (r,true));
  2498. jend();
  2499. r
  2500. | OpBoolAnd ->
  2501. let r = alloc_tmp ctx HBool in
  2502. let j = jump_expr ctx e1 false in
  2503. let j2 = jump_expr ctx e2 false in
  2504. op ctx (OBool (r,true));
  2505. let jend = jump ctx (fun b -> OJAlways b) in
  2506. j();
  2507. j2();
  2508. op ctx (OBool (r,false));
  2509. jend();
  2510. r
  2511. | OpAssignOp bop ->
  2512. (match get_access ctx e1 with
  2513. | ALocal (v,l) ->
  2514. let r = eval_to ctx { e with eexpr = TBinop (bop,e1,e2) } (to_type ctx e1.etype) in
  2515. push_op ctx (OMov (l, r));
  2516. add_assign ctx v;
  2517. r
  2518. | acc ->
  2519. gen_assign_op ctx acc e1 (fun r ->
  2520. hold ctx r;
  2521. let b = if bop = OpAdd && is_string (rtype ctx r) then to_string ctx (eval_expr ctx e2) e2.epos else eval_to ctx e2 (rtype ctx r) in
  2522. free ctx r;
  2523. arithbinop r r b;
  2524. r))
  2525. | OpInterval | OpArrow | OpIn | OpNullCoal ->
  2526. die "" __LOC__)
  2527. | TUnop (Not,_,v) ->
  2528. let tmp = alloc_tmp ctx HBool in
  2529. let r = eval_to ctx v HBool in
  2530. op ctx (ONot (tmp,r));
  2531. tmp
  2532. | TUnop (Neg,_,v) ->
  2533. let t = to_type ctx e.etype in
  2534. let tmp = alloc_tmp ctx t in
  2535. let r = eval_to ctx v t in
  2536. op ctx (ONeg (tmp,r));
  2537. tmp
  2538. | TUnop (Spread,_,_) ->
  2539. die ~p:e.epos "Unexpected spread operator" __LOC__
  2540. | TUnop (NegBits,_,v) ->
  2541. let t = to_type ctx e.etype in
  2542. let tmp = alloc_tmp ctx t in
  2543. let r = eval_to ctx v t in
  2544. let mask = (match t with
  2545. | HUI8 -> 0xFFl
  2546. | HUI16 -> 0xFFFFl
  2547. | HI32 -> 0xFFFFFFFFl
  2548. | _ -> abort ("Unsupported " ^ tstr t) e.epos
  2549. ) in
  2550. hold ctx r;
  2551. let r2 = alloc_tmp ctx t in
  2552. free ctx r;
  2553. op ctx (OInt (r2,alloc_i32 ctx mask));
  2554. op ctx (OXor (tmp,r,r2));
  2555. tmp
  2556. | TUnop (Increment|Decrement as uop,fix,v) ->
  2557. let rec unop r =
  2558. match rtype ctx r with
  2559. | HUI8 | HUI16 | HI32 | HI64 ->
  2560. if uop = Increment then op ctx (OIncr r) else op ctx (ODecr r)
  2561. | HF32 | HF64 as t ->
  2562. hold ctx r;
  2563. let tmp = alloc_tmp ctx t in
  2564. free ctx r;
  2565. op ctx (OFloat (tmp,alloc_float ctx 1.));
  2566. if uop = Increment then op ctx (OAdd (r,r,tmp)) else op ctx (OSub (r,r,tmp))
  2567. | HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as t) ->
  2568. hold ctx r;
  2569. let tmp = alloc_tmp ctx t in
  2570. free ctx r;
  2571. op ctx (OSafeCast (tmp,r));
  2572. unop tmp;
  2573. op ctx (OToDyn (r,tmp));
  2574. | HDyn when uop = Increment ->
  2575. hold ctx r;
  2576. let tmp = alloc_tmp ctx HDyn in
  2577. free ctx r;
  2578. op ctx (OToDyn (tmp, reg_int ctx 1));
  2579. op ctx (OCall2 (r,alloc_fun_path ctx ([],"Std") "__add__",r,tmp))
  2580. | HDyn when uop = Decrement ->
  2581. let r2 = alloc_tmp ctx HF64 in
  2582. hold ctx r2;
  2583. let tmp = alloc_tmp ctx HF64 in
  2584. free ctx r2;
  2585. op ctx (OSafeCast (r2, r));
  2586. op ctx (OFloat (tmp, alloc_float ctx 1.));
  2587. op ctx (OSub (r2, r2, tmp));
  2588. op ctx (OSafeCast (r, r2));
  2589. | _ ->
  2590. die "" __LOC__
  2591. in
  2592. (match get_access ctx v, fix with
  2593. | ALocal (v,r), Prefix ->
  2594. unop r;
  2595. r
  2596. | ALocal (v,r), Postfix ->
  2597. let r2 = alloc_tmp ctx (rtype ctx r) in
  2598. hold ctx r2;
  2599. op ctx (OMov (r2,r));
  2600. unop r;
  2601. free ctx r2;
  2602. r2
  2603. | acc, _ ->
  2604. let ret = ref 0 in
  2605. (match acc with AArray (a,_,idx) -> hold ctx a; hold ctx idx | _ -> ());
  2606. ignore(gen_assign_op ctx acc v (fun r ->
  2607. if fix = Prefix then ret := r else begin
  2608. hold ctx r;
  2609. let tmp = alloc_tmp ctx (rtype ctx r) in
  2610. free ctx r;
  2611. op ctx (OMov (tmp, r));
  2612. ret := tmp;
  2613. end;
  2614. hold ctx !ret;
  2615. unop r;
  2616. r)
  2617. );
  2618. free ctx !ret;
  2619. (match acc with AArray (a,_,idx) -> free ctx a; free ctx idx | _ -> ());
  2620. !ret)
  2621. | TFunction f ->
  2622. let fid = alloc_function_name ctx ("function#" ^ string_of_int (DynArray.length ctx.cfids.arr)) in
  2623. let capt = make_fun ctx ("","") fid f None (Some ctx.m.mcaptured) in
  2624. let r = alloc_tmp ctx (to_type ctx e.etype) in
  2625. if capt == ctx.m.mcaptured then
  2626. op ctx (OInstanceClosure (r, fid, ctx.m.mcaptreg))
  2627. else (match Array.length capt.c_vars with
  2628. | 0 ->
  2629. op ctx (OStaticClosure (r, fid))
  2630. | 1 when not capt.c_group ->
  2631. op ctx (OInstanceClosure (r, fid, eval_var ctx capt.c_vars.(0)))
  2632. | _ ->
  2633. let env = alloc_tmp ctx capt.c_type in
  2634. op ctx (OEnumAlloc (env,0));
  2635. hold ctx env;
  2636. Array.iteri (fun i v -> op ctx (OSetEnumField (env,i,eval_var ctx v))) capt.c_vars;
  2637. free ctx env;
  2638. op ctx (OInstanceClosure (r, fid, env)));
  2639. r
  2640. (* throwing a catch var means we want to rethrow an exception *)
  2641. | TThrow ({ eexpr = TLocal v } as e1) when has_var_flag v VCaught ->
  2642. let r = alloc_tmp ctx HVoid in
  2643. op ctx (ORethrow (eval_to ctx e1 HDyn));
  2644. r
  2645. | TThrow v ->
  2646. op ctx (OThrow (eval_to ctx v HDyn));
  2647. alloc_tmp ctx HDyn
  2648. | TWhile (cond,eloop,NormalWhile) ->
  2649. let oldb = ctx.m.mbreaks and oldc = ctx.m.mcontinues and oldtrys = ctx.m.mloop_trys in
  2650. ctx.m.mbreaks <- [];
  2651. ctx.m.mcontinues <- [];
  2652. ctx.m.mloop_trys <- ctx.m.mtrys;
  2653. let continue_pos = current_pos ctx in
  2654. let ret = jump_back ctx in
  2655. let j = jump_expr ctx cond false in
  2656. ignore(eval_expr ctx eloop);
  2657. set_curpos ctx (max_pos e);
  2658. ret();
  2659. j();
  2660. List.iter (fun f -> f (current_pos ctx)) ctx.m.mbreaks;
  2661. List.iter (fun f -> f continue_pos) ctx.m.mcontinues;
  2662. ctx.m.mbreaks <- oldb;
  2663. ctx.m.mcontinues <- oldc;
  2664. ctx.m.mloop_trys <- oldtrys;
  2665. alloc_tmp ctx HVoid
  2666. | TWhile (cond,eloop,DoWhile) ->
  2667. let oldb = ctx.m.mbreaks and oldc = ctx.m.mcontinues and oldtrys = ctx.m.mloop_trys in
  2668. ctx.m.mbreaks <- [];
  2669. ctx.m.mcontinues <- [];
  2670. ctx.m.mloop_trys <- ctx.m.mtrys;
  2671. let continue_pos = current_pos ctx in
  2672. let ret = jump_back ctx in
  2673. ignore(eval_expr ctx eloop);
  2674. let j = jump_expr ctx cond false in
  2675. ret();
  2676. j();
  2677. List.iter (fun f -> f (current_pos ctx)) ctx.m.mbreaks;
  2678. List.iter (fun f -> f continue_pos) ctx.m.mcontinues;
  2679. ctx.m.mbreaks <- oldb;
  2680. ctx.m.mcontinues <- oldc;
  2681. ctx.m.mloop_trys <- oldtrys;
  2682. alloc_tmp ctx HVoid
  2683. | TCast ({ eexpr = TCast (v,None) },None) when not (is_number (to_type ctx e.etype)) ->
  2684. (* coalesce double casts into a single runtime check - temp fix for Map accesses *)
  2685. eval_expr ctx { e with eexpr = TCast(v,None) }
  2686. | TCast (v,None) ->
  2687. let t = to_type ctx e.etype in
  2688. let rv = eval_expr ctx v in
  2689. (match t with
  2690. | HF32 | HF64 when unsigned v.etype ->
  2691. let r = alloc_tmp ctx t in
  2692. op ctx (OToUFloat (r,rv));
  2693. r
  2694. | HDyn when (match rtype ctx rv with HFun _ -> true | _ -> false) ->
  2695. (* if called, a HDyn method will return HDyn, not its usual return type *)
  2696. let r = alloc_tmp ctx t in
  2697. op ctx (OMov (r,rv));
  2698. r
  2699. | _ ->
  2700. cast_to ~force:true ctx rv t e.epos)
  2701. | TArrayDecl el ->
  2702. let r = alloc_tmp ctx (to_type ctx e.etype) in
  2703. let et = (match follow e.etype with TInst (_,[t]) -> to_type ctx t | _ -> die "" __LOC__) in
  2704. let array_bytes bits t tname get_op =
  2705. let b = alloc_tmp ctx HBytes in
  2706. let size = reg_int ctx ((List.length el) lsl bits) in
  2707. op ctx (OCall1 (b,alloc_std ctx "alloc_bytes" [HI32] HBytes,size));
  2708. let idx = reg_int ctx 0 in
  2709. hold ctx idx;
  2710. hold ctx b;
  2711. list_iteri (fun i e ->
  2712. let r = eval_to ctx e t in
  2713. hold ctx r;
  2714. op ctx (get_op b (shl ctx idx bits) r);
  2715. free ctx r;
  2716. op ctx (OIncr idx);
  2717. ) el;
  2718. free ctx b;
  2719. free ctx idx;
  2720. op ctx (OCall2 (r, alloc_fun_path ctx (["hl";"types"],"ArrayBase") ("alloc" ^ tname), b, reg_int ctx (List.length el)));
  2721. in
  2722. (match et with
  2723. | HI32 ->
  2724. array_bytes 2 HI32 "I32" (fun b i r -> OSetMem (b,i,r))
  2725. | HUI16 ->
  2726. array_bytes 1 HI32 "UI16" (fun b i r -> OSetUI16 (b,i,r))
  2727. | HF32 ->
  2728. array_bytes 2 HF32 "F32" (fun b i r -> OSetMem (b,i,r))
  2729. | HF64 ->
  2730. array_bytes 3 HF64 "F64" (fun b i r -> OSetMem (b,i,r))
  2731. | HI64 ->
  2732. array_bytes 3 HI64 "I64" (fun b i r -> OSetMem (b,i,r))
  2733. | _ ->
  2734. let at = if is_dynamic et then et else HDyn in
  2735. let size = reg_int ctx (List.length el) in
  2736. let a = alloc_array ctx size at in
  2737. hold ctx a;
  2738. list_iteri (fun i e ->
  2739. let r = eval_to ctx e at in
  2740. op ctx (OSetArray (a,reg_int ctx i,r));
  2741. ) el;
  2742. free ctx a;
  2743. let tmp = if et = HDyn then alloc_tmp ctx (class_type ctx ctx.array_impl.aobj [] false) else r in
  2744. op ctx (OCall1 (tmp, alloc_fun_path ctx (["hl";"types"],"ArrayObj") "alloc", a));
  2745. if tmp <> r then begin
  2746. let re = alloc_tmp ctx HBool in
  2747. op ctx (OBool (re,true));
  2748. let ren = alloc_tmp ctx (HRef HBool) in
  2749. op ctx (ORef (ren, re));
  2750. op ctx (OCall2 (r, alloc_fun_path ctx (["hl";"types"],"ArrayDyn") "alloc", tmp, ren));
  2751. end;
  2752. );
  2753. r
  2754. | TArray _ ->
  2755. (match get_access ctx e with
  2756. | AArray (a,at,idx) ->
  2757. array_read ctx a at idx e.epos
  2758. | ACArray (a,t,idx) ->
  2759. let tmp = alloc_tmp ctx t in
  2760. op ctx (OGetArray (tmp,a,idx));
  2761. tmp
  2762. | _ ->
  2763. die "" __LOC__)
  2764. | TMeta (_,e) ->
  2765. eval_expr ctx e
  2766. | TFor (v,it,loop) ->
  2767. eval_expr ctx (Texpr.for_remap ctx.com.basic v it loop e.epos)
  2768. | TSwitch {switch_subject = en;switch_cases = cases;switch_default = def} ->
  2769. let rt = to_type ctx e.etype in
  2770. let r = alloc_tmp ctx rt in
  2771. (try
  2772. let max = ref (-1) in
  2773. let get_int e =
  2774. match e.eexpr with
  2775. | TConst (TInt i) ->
  2776. let v = Int32.to_int i in
  2777. if Int32.of_int v <> i then raise Exit;
  2778. v
  2779. | _ ->
  2780. raise Exit
  2781. in
  2782. List.iter (fun case ->
  2783. List.iter (fun v ->
  2784. let i = get_int v in
  2785. if i < 0 then raise Exit;
  2786. if i > !max then max := i;
  2787. ) case.case_patterns;
  2788. ) cases;
  2789. if !max > 255 || cases = [] then raise Exit;
  2790. let ridx = eval_to ctx en HI32 in
  2791. let indexes = Array.make (!max + 1) 0 in
  2792. op ctx (OSwitch (ridx,indexes,0));
  2793. let switch_pos = current_pos ctx in
  2794. (match def with
  2795. | None ->
  2796. if rt <> HVoid then set_default ctx r;
  2797. | Some e ->
  2798. let re = eval_to ctx e rt in
  2799. if rt <> HVoid then op ctx (OMov (r,re)));
  2800. let jends = ref [jump ctx (fun i -> OJAlways i)] in
  2801. List.iter (fun {case_patterns = values;case_expr = ecase} ->
  2802. List.iter (fun v ->
  2803. Array.set indexes (get_int v) (current_pos ctx - switch_pos)
  2804. ) values;
  2805. let re = eval_to ctx ecase rt in
  2806. if rt <> HVoid then op ctx (OMov (r,re));
  2807. jends := jump ctx (fun i -> OJAlways i) :: !jends
  2808. ) cases;
  2809. set_op ctx (switch_pos - 1) (OSwitch (ridx,indexes,current_pos ctx - switch_pos));
  2810. List.iter (fun j -> j()) (!jends);
  2811. with Exit ->
  2812. let jends = ref [] in
  2813. let rvalue = eval_expr ctx en in
  2814. let loop {case_patterns = cases;case_expr = e} =
  2815. hold ctx rvalue;
  2816. let ok = List.map (fun c ->
  2817. let ct = common_type ctx en c true c.epos in
  2818. match c.eexpr, ct with
  2819. | TConst (TString str), HObj { pname = "String" } ->
  2820. let jnull = jump ctx (fun n -> OJNull (rvalue,n)) in
  2821. (* compare len *)
  2822. let rlen = alloc_tmp ctx HI32 in
  2823. op ctx (OField (rlen, rvalue, 1));
  2824. hold ctx rlen;
  2825. let str, len = to_utf8 str c.epos in
  2826. let rlen2 = reg_int ctx len in
  2827. let jdiff = jump ctx (fun n -> OJNotEq (rlen, rlen2, n)) in
  2828. free ctx rlen;
  2829. (* compare data *)
  2830. let rbytes = alloc_tmp ctx HBytes in
  2831. op ctx (OField (rbytes, rvalue, 0));
  2832. hold ctx rbytes;
  2833. let rbytes2 = alloc_tmp ctx HBytes in
  2834. op ctx (OString (rbytes2,alloc_string ctx str));
  2835. let result = alloc_tmp ctx HI32 in
  2836. op ctx (OCall3 (result, alloc_std ctx "string_compare" [HBytes;HBytes;HI32] HI32,rbytes,rbytes2,rlen));
  2837. free ctx rbytes;
  2838. hold ctx result;
  2839. let zero = reg_int ctx 0 in
  2840. let jok = jump ctx (fun n -> OJEq (result, zero, n)) in
  2841. free ctx result;
  2842. jnull();
  2843. jdiff();
  2844. jok
  2845. | _ ->
  2846. let r = eval_to ctx c ct in
  2847. jump ctx (fun n -> OJEq (r,rvalue,n))
  2848. ) cases in
  2849. free ctx rvalue;
  2850. (fun() ->
  2851. List.iter (fun f -> f()) ok;
  2852. let re = eval_to ctx e rt in
  2853. if rt <> HVoid then op ctx (OMov (r,re));
  2854. jends := jump ctx (fun n -> OJAlways n) :: !jends)
  2855. in
  2856. let all = List.map loop cases in
  2857. (match def with
  2858. | None ->
  2859. if rt <> HVoid then op ctx (ONull r)
  2860. | Some e ->
  2861. let rdef = eval_to ctx e rt in
  2862. if rt <> HVoid then op ctx (OMov (r,rdef)));
  2863. jends := jump ctx (fun n -> OJAlways n) :: !jends;
  2864. List.iter (fun f -> f()) all;
  2865. List.iter (fun j -> j()) (!jends);
  2866. );
  2867. r
  2868. | TEnumParameter (ec,f,index) ->
  2869. let pt, is_single = (match to_type ctx ec.etype with
  2870. | HEnum e ->
  2871. let _,_,args = e.efields.(f.ef_index) in
  2872. args.(index), Array.length e.efields = 1
  2873. | _ -> die "" __LOC__
  2874. ) in
  2875. let er = eval_expr ctx ec in
  2876. if is_single then op ctx (ONullCheck er); (* #7560 *)
  2877. let r = alloc_tmp ctx pt in
  2878. op ctx (OEnumField (r,er,f.ef_index,index));
  2879. cast_to ctx r (to_type ctx e.etype) e.epos
  2880. | TContinue ->
  2881. before_break_continue ctx;
  2882. let pos = current_pos ctx in
  2883. op ctx (OJAlways (-1)); (* loop *)
  2884. ctx.m.mcontinues <- (fun target -> set_op ctx pos (OJAlways (target - (pos + 1)))) :: ctx.m.mcontinues;
  2885. alloc_tmp ctx HVoid
  2886. | TBreak ->
  2887. before_break_continue ctx;
  2888. let pos = current_pos ctx in
  2889. op ctx (OJAlways (-1)); (* loop *)
  2890. ctx.m.mbreaks <- (fun target -> set_op ctx pos (OJAlways (target - (pos + 1)))) :: ctx.m.mbreaks;
  2891. alloc_tmp ctx HVoid
  2892. | TTry (etry,catches) ->
  2893. let pos = current_pos ctx in
  2894. let rtrap = alloc_tmp ctx HDyn in
  2895. op ctx (OTrap (rtrap,-1)); (* loop *)
  2896. ctx.m.mtrys <- ctx.m.mtrys + 1;
  2897. let tret = to_type ctx e.etype in
  2898. let result = alloc_tmp ctx tret in
  2899. let r = eval_expr ctx etry in
  2900. if tret <> HVoid then op ctx (OMov (result,cast_to ctx r tret etry.epos));
  2901. ctx.m.mtrys <- ctx.m.mtrys - 1;
  2902. op ctx (OEndTrap true);
  2903. let j = jump ctx (fun n -> OJAlways n) in
  2904. set_op ctx pos (OTrap (rtrap, current_pos ctx - (pos + 1)));
  2905. let rec loop l =
  2906. match l with
  2907. | [] ->
  2908. op ctx (ORethrow rtrap);
  2909. []
  2910. | (v,ec) :: next ->
  2911. let rv = alloc_var ctx v true in
  2912. let jnext = if follow v.v_type == t_dynamic then begin
  2913. op ctx (OMov (rv, rtrap));
  2914. (fun() -> ())
  2915. end else
  2916. let ct = (match follow v.v_type with
  2917. | TInst (c,_) -> TClassDecl c
  2918. | TAbstract (a,_) -> TAbstractDecl a
  2919. | TEnum (e,_) -> TEnumDecl e
  2920. | _ -> die "" __LOC__
  2921. ) in
  2922. hold ctx rtrap;
  2923. let r = type_value ctx ct ec.epos in
  2924. free ctx rtrap;
  2925. let rb = alloc_tmp ctx HBool in
  2926. op ctx (OCall2 (rb, alloc_fun_path ctx (["hl"],"BaseType") "check",r,rtrap));
  2927. let jnext = jump ctx (fun n -> OJFalse (rb,n)) in
  2928. op ctx (OMov (rv, unsafe_cast_to ~debugchk:false ctx rtrap (to_type ctx v.v_type) ec.epos));
  2929. add_assign ctx v;
  2930. jnext
  2931. in
  2932. let r = eval_expr ctx ec in
  2933. if tret <> HVoid then op ctx (OMov (result,cast_to ctx r tret ec.epos));
  2934. if follow v.v_type == t_dynamic then [] else
  2935. let jend = jump ctx (fun n -> OJAlways n) in
  2936. jnext();
  2937. jend :: loop next
  2938. in
  2939. List.iter (fun j -> j()) (loop catches);
  2940. j();
  2941. result
  2942. | TTypeExpr t ->
  2943. type_value ctx t e.epos
  2944. | TCast (ev,Some _) ->
  2945. let t = to_type ctx e.etype in
  2946. let re = eval_expr ctx ev in
  2947. let rt = alloc_tmp ctx t in
  2948. if safe_cast (rtype ctx re) t then
  2949. op ctx (OMov (rt,re))
  2950. else (match Abstract.follow_with_abstracts e.etype with
  2951. | TInst(c,_) when (has_class_flag c CInterface) ->
  2952. hold ctx re;
  2953. let c = eval_to ctx { eexpr = TTypeExpr(TClassDecl c); epos = e.epos; etype = t_dynamic } (class_type ctx ctx.base_type [] false) in
  2954. hold ctx c;
  2955. let rb = alloc_tmp ctx HBool in
  2956. op ctx (OCall2 (rb, alloc_fun_path ctx (["hl"],"BaseType") "check",c,re));
  2957. let jnext = jump ctx (fun n -> OJTrue (rb,n)) in
  2958. let jnext2 = jump ctx (fun n -> OJNull (re,n)) in
  2959. op ctx (OThrow (make_string ctx "Cast error" e.epos));
  2960. jnext();
  2961. jnext2();
  2962. op ctx (OMov (rt, unsafe_cast_to ~debugchk:false ctx re (to_type ctx e.etype) e.epos));
  2963. free ctx c;
  2964. free ctx re;
  2965. | _ ->
  2966. op ctx (OSafeCast (rt,re)));
  2967. rt
  2968. | TIdent s ->
  2969. abort ("Unbound identifier " ^ s) e.epos
  2970. and gen_assign_op ctx acc e1 f =
  2971. let f r =
  2972. match rtype ctx r with
  2973. | HNull t ->
  2974. let r2 = alloc_tmp ctx t in
  2975. op ctx (OSafeCast (r2,r));
  2976. let r3 = alloc_tmp ctx (HNull t) in
  2977. op ctx (OToDyn (r3,f r2));
  2978. r3
  2979. | _ ->
  2980. f r
  2981. in
  2982. match acc with
  2983. | AInstanceField (eobj, findex) ->
  2984. let robj = eval_null_check ctx eobj in
  2985. hold ctx robj;
  2986. let t = real_type ctx e1 in
  2987. let r = alloc_tmp ctx t in
  2988. op ctx (OField (r,robj,findex));
  2989. let r = cast_to ctx r (to_type ctx e1.etype) e1.epos in
  2990. let r = f r in
  2991. free ctx robj;
  2992. op ctx (OSetField (robj,findex,cast_to ctx r t e1.epos));
  2993. r
  2994. | AStaticVar (g,t,fid) ->
  2995. let o = alloc_tmp ctx t in
  2996. op ctx (OGetGlobal (o,g));
  2997. let r = alloc_tmp ctx (to_type ctx e1.etype) in
  2998. op ctx (OField (r,o,fid));
  2999. hold ctx o;
  3000. let r = f r in
  3001. free ctx o;
  3002. op ctx (OSetField (o,fid,r));
  3003. r
  3004. | AGlobal g ->
  3005. let r = alloc_tmp ctx (to_type ctx e1.etype) in
  3006. op ctx (OGetGlobal (r,g));
  3007. let r = f r in
  3008. op ctx (OSetGlobal (g,r));
  3009. r
  3010. | ACaptured idx ->
  3011. let r = alloc_tmp ctx (to_type ctx e1.etype) in
  3012. op ctx (OEnumField (r, ctx.m.mcaptreg, 0, idx));
  3013. let r = f r in
  3014. op ctx (OSetEnumField (ctx.m.mcaptreg,idx,r));
  3015. r
  3016. | AArray (ra,(at,vt),ridx) ->
  3017. hold ctx ra;
  3018. hold ctx ridx;
  3019. let r = (match at with
  3020. | HDyn ->
  3021. (* call getDyn() *)
  3022. let r = alloc_tmp ctx HDyn in
  3023. op ctx (OCallMethod (r,0,[ra;ridx]));
  3024. let r = f r in
  3025. (* call setDyn() *)
  3026. op ctx (OCallMethod (alloc_tmp ctx HVoid,1,[ra;ridx;r]));
  3027. r
  3028. | _ ->
  3029. (* bounds check against length *)
  3030. let len = alloc_tmp ctx HI32 in
  3031. op ctx (OField (len,ra,0)); (* length *)
  3032. let j = jump ctx (fun i -> OJULt (ridx,len,i)) in
  3033. op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx (array_class ctx at).cl_path "__expand", ra, ridx));
  3034. j();
  3035. match at with
  3036. | HUI8 | HUI16 | HI32 | HF32 | HF64 | HI64->
  3037. let hbytes = alloc_tmp ctx HBytes in
  3038. op ctx (OField (hbytes, ra, 1));
  3039. let ridx = shl ctx ridx (type_size_bits at) in
  3040. hold ctx ridx;
  3041. hold ctx hbytes;
  3042. let r = alloc_tmp ctx at in
  3043. read_mem ctx r hbytes ridx at;
  3044. let r = f r in
  3045. write_mem ctx hbytes ridx at r;
  3046. free ctx ridx;
  3047. free ctx hbytes;
  3048. r
  3049. | _ ->
  3050. let arr = alloc_tmp ctx (HArray vt) in
  3051. op ctx (OField (arr,ra,1));
  3052. let r = alloc_tmp ctx at in
  3053. op ctx (OGetArray (r,arr,ridx));
  3054. hold ctx arr;
  3055. let r = f r in
  3056. free ctx arr;
  3057. op ctx (OSetArray (arr,ridx,r));
  3058. r
  3059. ) in
  3060. free ctx ra;
  3061. free ctx ridx;
  3062. r
  3063. | ADynamic (eobj, fid) ->
  3064. let robj = eval_null_check ctx eobj in
  3065. hold ctx robj;
  3066. let t = real_type ctx e1 in
  3067. let r = alloc_tmp ctx t in
  3068. op ctx (ODynGet (r,robj,fid));
  3069. let r = cast_to ctx r (to_type ctx e1.etype) e1.epos in
  3070. let r = f r in
  3071. let r = cast_to ctx r t e1.epos in
  3072. free ctx robj;
  3073. op ctx (ODynSet (robj,fid,r));
  3074. r
  3075. | ANone | ALocal _ | AStaticFun _ | AInstanceFun _ | AInstanceProto _ | AVirtualMethod _ | AEnum _ | ACArray _ ->
  3076. die "" __LOC__
  3077. and build_capture_vars ctx f =
  3078. let ignored_vars = ref PMap.empty in
  3079. let used_vars = ref PMap.empty in
  3080. (* get all captured vars in scope, ignore vars that are declared *)
  3081. let decl_var v =
  3082. if has_var_flag v VCaptured then ignored_vars := PMap.add v.v_id () !ignored_vars
  3083. in
  3084. let use_var v =
  3085. if has_var_flag v VCaptured then used_vars := PMap.add v.v_id v !used_vars
  3086. in
  3087. let rec loop e =
  3088. (match e.eexpr with
  3089. | TLocal v ->
  3090. use_var v;
  3091. | TVar (v,_) ->
  3092. decl_var v
  3093. | TTry (_,catches) ->
  3094. List.iter (fun (v,_) -> decl_var v) catches
  3095. | TFunction f ->
  3096. List.iter (fun (v,_) -> decl_var v) f.tf_args;
  3097. | _ ->
  3098. ()
  3099. );
  3100. Type.iter loop e
  3101. in
  3102. List.iter (fun (v,_) -> decl_var v) f.tf_args;
  3103. loop f.tf_expr;
  3104. let cvars = Array.of_list (PMap.fold (fun v acc -> if PMap.mem v.v_id !ignored_vars then acc else v :: acc) !used_vars []) in
  3105. Array.sort (fun v1 v2 -> v1.v_id - v2.v_id) cvars;
  3106. let indexes = ref PMap.empty in
  3107. let v0t = (if Array.length cvars = 1 then to_type ctx cvars.(0).v_type else HDyn) in
  3108. let ct, group = (match Array.length cvars with
  3109. | 0 -> HVoid, false
  3110. | 1 when is_nullable v0t -> v0t, false
  3111. | _ ->
  3112. Array.iteri (fun i v -> indexes := PMap.add v.v_id i !indexes) cvars;
  3113. let ctypes = Array.map (fun v -> to_type ctx v.v_type) cvars in
  3114. let ct = tuple_type ctx (Array.to_list ctypes) in
  3115. ct, true
  3116. ) in
  3117. {
  3118. c_map = !indexes;
  3119. c_vars = cvars;
  3120. c_type = ct;
  3121. c_group = group;
  3122. }
  3123. and gen_method_wrapper ctx rt t p =
  3124. try
  3125. PMap.find (rt,t) ctx.method_wrappers
  3126. with Not_found ->
  3127. let fid = lookup_alloc ctx.cfids () in
  3128. ctx.method_wrappers <- PMap.add (rt,t) fid ctx.method_wrappers;
  3129. let old = ctx.m in
  3130. let targs, tret = (match t with HFun (args, ret) -> args, ret | _ -> die "" __LOC__) in
  3131. let iargs, iret = (match rt with HFun (args, ret) -> args, ret | _ -> die "" __LOC__) in
  3132. ctx.m <- method_context fid HDyn null_capture false;
  3133. let rfun = alloc_tmp ctx rt in
  3134. let rargs = List.map (fun t ->
  3135. let r = alloc_tmp ctx t in
  3136. hold ctx r;
  3137. r
  3138. ) targs in
  3139. let casts = List.map2 (fun r t -> let r2 = cast_to ~force:true ctx r t p in hold ctx r2; free ctx r; r2) rargs iargs in
  3140. List.iter (free ctx) casts;
  3141. let rret = alloc_tmp ctx iret in
  3142. op ctx (OCallClosure (rret,rfun,casts));
  3143. op ctx (ORet (cast_to ctx rret tret p));
  3144. let f = {
  3145. fpath = "","";
  3146. findex = fid;
  3147. ftype = HFun (rt :: targs, tret);
  3148. regs = DynArray.to_array ctx.m.mregs.arr;
  3149. code = DynArray.to_array ctx.m.mops;
  3150. debug = make_debug ctx ctx.m.mdebug;
  3151. assigns = Array.of_list (List.rev ctx.m.massign);
  3152. } in
  3153. ctx.m <- old;
  3154. DynArray.add ctx.cfunctions f;
  3155. fid
  3156. and make_fun ?gen_content ctx name fidx f cthis cparent =
  3157. let old = ctx.m in
  3158. let capt = build_capture_vars ctx f in
  3159. let has_captured_vars = Array.length capt.c_vars > 0 in
  3160. let capt, use_parent_capture = (match cparent with
  3161. | Some cparent when has_captured_vars && List.for_all (fun v -> PMap.mem v.v_id cparent.c_map) (Array.to_list capt.c_vars) -> cparent, true
  3162. | _ -> capt, false
  3163. ) in
  3164. ctx.m <- method_context fidx (to_type ctx f.tf_type) capt (cthis <> None);
  3165. set_curpos ctx f.tf_expr.epos;
  3166. let tthis = (match cthis with
  3167. | None -> None
  3168. | Some c ->
  3169. let t = to_type ctx (TInst (c,[])) in
  3170. hold ctx (alloc_tmp ctx t); (* index 0 *)
  3171. Some t
  3172. ) in
  3173. let rcapt = match has_captured_vars && cparent <> None with
  3174. | true when capt.c_group ->
  3175. let r = alloc_tmp ctx capt.c_type in
  3176. hold ctx r;
  3177. Some r
  3178. | true ->
  3179. Some (alloc_var ctx capt.c_vars.(0) true)
  3180. | false ->
  3181. None
  3182. in
  3183. let args = List.map (fun (v,o) ->
  3184. let t = to_type ctx v.v_type in
  3185. let r = alloc_var ctx (if o = None then v else { v with v_type = if not (is_nullable t) then TAbstract(ctx.ref_abstract,[v.v_type]) else v.v_type }) true in
  3186. add_assign ~force:true ctx v; (* record var name *)
  3187. rtype ctx r
  3188. ) f.tf_args in
  3189. if has_captured_vars then ctx.m.mcaptreg <- (match rcapt with
  3190. | None when not capt.c_group ->
  3191. -1
  3192. | None ->
  3193. let r = alloc_tmp ctx capt.c_type in
  3194. hold ctx r;
  3195. op ctx (OEnumAlloc (r,0));
  3196. add_capture ctx r;
  3197. r
  3198. | Some r ->
  3199. add_capture ctx r;
  3200. r
  3201. );
  3202. List.iter (fun (v, o) ->
  3203. let r = alloc_var ctx v false in
  3204. let vt = to_type ctx v.v_type in
  3205. let capt = captured_index ctx v in
  3206. (match o with
  3207. | None | Some {eexpr = TConst TNull} -> ()
  3208. | Some c when not (is_nullable vt) ->
  3209. (* if optional but not null, turn into a not nullable here *)
  3210. let j = jump ctx (fun n -> OJNotNull (r,n)) in
  3211. let t = alloc_tmp ctx vt in
  3212. (match vt with
  3213. | HUI8 | HUI16 | HI32 | HI64 ->
  3214. (match c.eexpr with
  3215. | TConst (TInt i) -> op ctx (OInt (t,alloc_i32 ctx i))
  3216. | TConst (TFloat s) -> op ctx (OInt (t,alloc_i32 ctx (Int32.of_float (float_of_string s))))
  3217. | _ -> die "" __LOC__)
  3218. | HF32 | HF64 ->
  3219. (match c.eexpr with
  3220. | TConst (TInt i) -> op ctx (OFloat (t,alloc_float ctx (Int32.to_float i)))
  3221. | TConst (TFloat s) -> op ctx (OFloat (t,alloc_float ctx (float_of_string s)))
  3222. | _ -> die "" __LOC__)
  3223. | HBool ->
  3224. (match c.eexpr with
  3225. | TConst (TBool b) -> op ctx (OBool (t,b))
  3226. | _ -> die "" __LOC__)
  3227. | _ ->
  3228. die "" __LOC__);
  3229. if capt = None then add_assign ctx v;
  3230. let jend = jump ctx (fun n -> OJAlways n) in
  3231. j();
  3232. op ctx (OUnref (t,r));
  3233. if capt = None then add_assign ctx v;
  3234. jend();
  3235. Hashtbl.replace ctx.m.mvars v.v_id t;
  3236. free ctx r;
  3237. hold ctx t
  3238. | Some c ->
  3239. let j = jump ctx (fun n -> OJNotNull (r,n)) in
  3240. (match c.eexpr with
  3241. | TConst (TNull | TThis | TSuper) -> die "" __LOC__
  3242. | TConst (TInt i) when (match to_type ctx (Abstract.follow_with_abstracts v.v_type) with HUI8 | HUI16 | HI32 | HI64 | HDyn -> true | _ -> false) ->
  3243. let tmp = alloc_tmp ctx HI32 in
  3244. op ctx (OInt (tmp, alloc_i32 ctx i));
  3245. op ctx (OToDyn (r, tmp));
  3246. | TConst (TFloat s) when (match to_type ctx (Abstract.follow_with_abstracts v.v_type) with HUI8 | HUI16 | HI32 | HI64 -> true | _ -> false) ->
  3247. let tmp = alloc_tmp ctx HI32 in
  3248. op ctx (OInt (tmp, alloc_i32 ctx (Int32.of_float (float_of_string s))));
  3249. op ctx (OToDyn (r, tmp));
  3250. | TConst (TInt i) ->
  3251. let tmp = alloc_tmp ctx HF64 in
  3252. op ctx (OFloat (tmp, alloc_float ctx (Int32.to_float i)));
  3253. op ctx (OToDyn (r, tmp));
  3254. | TConst (TFloat s) ->
  3255. let tmp = alloc_tmp ctx HF64 in
  3256. op ctx (OFloat (tmp, alloc_float ctx (float_of_string s)));
  3257. op ctx (OToDyn (r, tmp));
  3258. | TConst (TBool b) ->
  3259. let tmp = alloc_tmp ctx HBool in
  3260. op ctx (OBool (tmp, b));
  3261. op ctx (OToDyn (r, tmp));
  3262. | TConst (TString s) ->
  3263. op ctx (OMov (r, make_string ctx s f.tf_expr.epos))
  3264. | _ ->
  3265. op ctx (OMov (r, eval_to ctx c vt))
  3266. );
  3267. j();
  3268. );
  3269. (match capt with
  3270. | None -> ()
  3271. | Some index ->
  3272. op ctx (OSetEnumField (ctx.m.mcaptreg, index, alloc_var ctx v false)));
  3273. ) f.tf_args;
  3274. (match gen_content with
  3275. | None -> ()
  3276. | Some f -> f());
  3277. ignore(eval_expr ctx f.tf_expr);
  3278. let tret = to_type ctx f.tf_type in
  3279. let rec has_final_jump e =
  3280. (* prevents a jump outside function bounds error *)
  3281. match e.eexpr with
  3282. | TBlock el -> (match List.rev el with e :: _ -> has_final_jump e | [] -> false)
  3283. | TParenthesis e -> has_final_jump e
  3284. | TReturn _ -> false
  3285. | _ -> true
  3286. in
  3287. set_curpos ctx (max_pos f.tf_expr);
  3288. if tret = HVoid then
  3289. op ctx (ORet (alloc_tmp ctx HVoid))
  3290. else if has_final_jump f.tf_expr then begin
  3291. let r = alloc_tmp ctx tret in
  3292. (match tret with
  3293. | HI32 | HUI8 | HUI16 | HI64 -> op ctx (OInt (r,alloc_i32 ctx 0l))
  3294. | HF32 | HF64 -> op ctx (OFloat (r,alloc_float ctx 0.))
  3295. | HBool -> op ctx (OBool (r,false))
  3296. | _ -> op ctx (ONull r));
  3297. op ctx (ORet r)
  3298. end;
  3299. let fargs = (match tthis with None -> [] | Some t -> [t]) @ (match rcapt with None -> [] | Some r -> [rtype ctx r]) @ args in
  3300. let hlf = {
  3301. fpath = name;
  3302. findex = fidx;
  3303. ftype = HFun (fargs, tret);
  3304. regs = DynArray.to_array ctx.m.mregs.arr;
  3305. code = DynArray.to_array ctx.m.mops;
  3306. debug = make_debug ctx ctx.m.mdebug;
  3307. assigns = Array.of_list (List.rev ctx.m.massign);
  3308. } in
  3309. ctx.m <- old;
  3310. Hashtbl.add ctx.defined_funs fidx ();
  3311. let f = if ctx.optimize && (gen_content = None || name <> ("","")) then begin
  3312. let t = Timer.timer ["generate";"hl";"opt"] in
  3313. let f = Hlopt.optimize ctx.dump_out (DynArray.get ctx.cstrings.arr) hlf f in
  3314. t();
  3315. f
  3316. end else
  3317. hlf
  3318. in
  3319. DynArray.add ctx.cfunctions f;
  3320. capt
  3321. let generate_static ctx c f =
  3322. match f.cf_kind with
  3323. | Var _ ->
  3324. ()
  3325. | Method _ when has_class_field_flag f CfExtern ->
  3326. ()
  3327. | Method m ->
  3328. let add_native lib name =
  3329. let fid = alloc_fid ctx c f in
  3330. ignore(lookup ctx.cnatives (name ^ "@" ^ lib,fid) (fun() ->
  3331. Hashtbl.add ctx.defined_funs fid ();
  3332. (alloc_string ctx lib, alloc_string ctx name,to_type ctx f.cf_type,fid)
  3333. ));
  3334. in
  3335. let rec loop = function
  3336. | (Meta.HlNative,[(EConst(String(lib,_)),_);(EConst(String(name,_)),_)] ,_ ) :: _ ->
  3337. add_native lib name
  3338. | (Meta.HlNative,[(EConst(String(lib,_)),_)] ,_ ) :: _ ->
  3339. add_native lib f.cf_name
  3340. | (Meta.HlNative,[(EConst(Float(ver,_)),_)] ,_ ) :: _ ->
  3341. let cur_ver = (try Common.defined_value ctx.com Define.HlVer with Not_found -> "") in
  3342. if cur_ver < ver then
  3343. let gen_content() =
  3344. op ctx (OThrow (make_string ctx ("Requires compiling with -D hl-ver=" ^ ver ^ ".0 or higher") null_pos));
  3345. in
  3346. (match f.cf_expr with
  3347. | Some { eexpr = TFunction fn } -> ignore(make_fun ctx ~gen_content (s_type_path c.cl_path,f.cf_name) (alloc_fid ctx c f) fn None None)
  3348. | _ -> if not (Meta.has Meta.NoExpr f.cf_meta) then abort "Missing function body" f.cf_pos)
  3349. else
  3350. add_native "std" f.cf_name
  3351. | (Meta.HlNative,[] ,_ ) :: _ ->
  3352. add_native "std" f.cf_name
  3353. | (Meta.HlNative,_ ,p) :: _ ->
  3354. abort "Invalid @:hlNative decl" p
  3355. | [] ->
  3356. (match f.cf_expr with
  3357. | Some { eexpr = TFunction fn } -> ignore(make_fun ctx (s_type_path c.cl_path,f.cf_name) (alloc_fid ctx c f) fn None None)
  3358. | _ -> if not (Meta.has Meta.NoExpr f.cf_meta) then abort "Missing function body" f.cf_pos)
  3359. | _ :: l ->
  3360. loop l
  3361. in
  3362. loop f.cf_meta
  3363. let generate_member ctx c f =
  3364. match f.cf_kind with
  3365. | Var _ -> ()
  3366. | _ when is_extern_field f -> ()
  3367. | Method m ->
  3368. let gen_content = if f.cf_name <> "new" then None else Some (fun() ->
  3369. let o = (match class_type ctx c (extract_param_types c.cl_params) false with
  3370. | HObj o | HStruct o -> o
  3371. | _ -> die "" __LOC__
  3372. ) in
  3373. (*
  3374. init dynamic functions
  3375. *)
  3376. List.iter (fun f ->
  3377. match f.cf_kind with
  3378. | Method MethDynamic ->
  3379. let r = alloc_tmp ctx (to_type ctx f.cf_type) in
  3380. let fid = (try fst (get_index f.cf_name o) with Not_found -> die "" __LOC__) in
  3381. op ctx (OGetThis (r,fid));
  3382. op ctx (OJNotNull (r,2));
  3383. op ctx (OInstanceClosure (r,alloc_fid ctx c f,0));
  3384. op ctx (OSetThis (fid,r));
  3385. | _ -> ()
  3386. ) c.cl_ordered_fields;
  3387. ) in
  3388. let ff = match f.cf_expr with
  3389. | Some { eexpr = TFunction f } -> f
  3390. | None when has_class_field_flag f CfAbstract ->
  3391. let tl,tr = match follow f.cf_type with
  3392. | TFun(tl,tr) -> tl,tr
  3393. | _ -> die "" __LOC__
  3394. in
  3395. let args = List.map (fun (n,_,t) ->
  3396. let v = Type.alloc_var VGenerated n t null_pos in
  3397. (v,None)
  3398. ) tl in
  3399. {
  3400. tf_args = args;
  3401. tf_type = tr;
  3402. tf_expr = mk (TThrow (mk (TConst TNull) t_dynamic null_pos)) t_dynamic null_pos;
  3403. }
  3404. | _ -> abort "Missing function body" f.cf_pos
  3405. in
  3406. ignore(make_fun ?gen_content ctx (s_type_path c.cl_path,f.cf_name) (alloc_fid ctx c f) ff (Some c) None);
  3407. if f.cf_name = "toString" && not (has_class_field_flag f CfOverride) && not (PMap.mem "__string" c.cl_fields) && is_to_string f.cf_type then begin
  3408. let p = f.cf_pos in
  3409. (* function __string() return this.toString().bytes *)
  3410. let ethis = mk (TConst TThis) (TInst (c,extract_param_types c.cl_params)) p in
  3411. let tstr = mk (TCall (mk (TField (ethis,FInstance(c,extract_param_types c.cl_params,f))) f.cf_type p,[])) ctx.com.basic.tstring p in
  3412. let cstr, cf_bytes = (try (match ctx.com.basic.tstring with TInst(c,_) -> c, PMap.find "bytes" c.cl_fields | _ -> die "" __LOC__) with Not_found -> die "" __LOC__) in
  3413. let estr = mk (TReturn (Some (mk (TField (tstr,FInstance (cstr,[],cf_bytes))) cf_bytes.cf_type p))) ctx.com.basic.tvoid p in
  3414. ignore(make_fun ctx (s_type_path c.cl_path,"__string") (alloc_fun_path ctx c.cl_path "__string") { tf_expr = estr; tf_args = []; tf_type = cf_bytes.cf_type; } (Some c) None)
  3415. end
  3416. let generate_type ctx t =
  3417. match t with
  3418. | TClassDecl c when (has_class_flag c CInterface) ->
  3419. ()
  3420. | TClassDecl c when (has_class_flag c CExtern) ->
  3421. List.iter (fun f ->
  3422. List.iter (fun (name,args,pos) ->
  3423. match name with
  3424. | Meta.HlNative -> generate_static ctx c f
  3425. | _ -> ()
  3426. ) f.cf_meta
  3427. ) c.cl_ordered_statics
  3428. | TClassDecl c ->
  3429. List.iter (generate_static ctx c) c.cl_ordered_statics;
  3430. (match c.cl_constructor with
  3431. | None -> ()
  3432. | Some f ->
  3433. let merge_inits e =
  3434. match e with
  3435. | Some ({ eexpr = TFunction ({ tf_expr = { eexpr = TBlock el } as ef } as f) } as e) ->
  3436. let merge ei =
  3437. let rec loop ei =
  3438. let ei = Type.map_expr loop ei in
  3439. { ei with epos = e.epos }
  3440. in
  3441. if ei.epos.pmin < e.epos.pmin || ei.epos.pmax > e.epos.pmax then loop ei else ei
  3442. in
  3443. Some { e with eexpr = TFunction({ f with tf_expr = { ef with eexpr = TBlock (List.map merge el) }}) }
  3444. | _ ->
  3445. e
  3446. in
  3447. generate_member ctx c { f with cf_expr = merge_inits f.cf_expr });
  3448. List.iter (generate_member ctx c) c.cl_ordered_fields;
  3449. | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ ->
  3450. ()
  3451. let generate_static_init ctx types main =
  3452. let exprs = ref [] in
  3453. let t_void = ctx.com.basic.tvoid in
  3454. let gen_content() =
  3455. let is_init = alloc_tmp ctx HBool in
  3456. op ctx (OCall0 (is_init, alloc_fun_path ctx ([],"Type") "init"));
  3457. hold ctx is_init;
  3458. (* init class values *)
  3459. List.iter (fun t ->
  3460. match t with
  3461. | TClassDecl c when not (has_class_flag c CExtern) && not (is_array_class (s_type_path c.cl_path) && snd c.cl_path <> "ArrayDyn") && c != ctx.core_type && c != ctx.core_enum ->
  3462. let path = if c == ctx.array_impl.abase then [],"Array" else if c == ctx.base_class then [],"Class" else c.cl_path in
  3463. let g, ct = class_global ~resolve:false ctx c in
  3464. let ctype = if c == ctx.array_impl.abase then ctx.array_impl.aall else c in
  3465. let t = class_type ctx ctype (extract_param_types ctype.cl_params) false in
  3466. let index name =
  3467. match ct with
  3468. | HObj o ->
  3469. fst (try get_index name o with Not_found -> die "" __LOC__)
  3470. | _ ->
  3471. die "" __LOC__
  3472. in
  3473. let rc = (match t with
  3474. | HObj o when (match o.pclassglobal with None -> -1 | Some i -> i) <> g ->
  3475. (* manual registration for objects with prototype tricks (Array) *)
  3476. let rc = alloc_tmp ctx ct in
  3477. op ctx (ONew rc);
  3478. op ctx (OSetGlobal (g,rc));
  3479. hold ctx rc;
  3480. let rt = alloc_tmp ctx HType in
  3481. op ctx (OType (rt, t));
  3482. op ctx (OSetField (rc,index "__type__",rt));
  3483. op ctx (OSetField (rc,index "__name__",eval_expr ctx { eexpr = TConst (TString (s_type_path path)); epos = c.cl_pos; etype = ctx.com.basic.tstring }));
  3484. let rname = alloc_tmp ctx HBytes in
  3485. op ctx (OString (rname, alloc_string ctx (s_type_path path)));
  3486. op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx ([],"Type") "register",rname,rc));
  3487. rc
  3488. | _ ->
  3489. let rct = alloc_tmp ctx HType in
  3490. op ctx (OType (rct, ct));
  3491. hold ctx rct;
  3492. let rt = alloc_tmp ctx HType in
  3493. op ctx (OType (rt, t));
  3494. let rname = alloc_tmp ctx HBytes in
  3495. op ctx (OString (rname, alloc_string ctx (s_type_path path)));
  3496. let rc = alloc_tmp ctx (class_type ctx ctx.base_class [] false) in
  3497. op ctx (OCall3 (rc, alloc_fun_path ctx ([],"Type") "initClass", rct, rt, rname));
  3498. hold ctx rc;
  3499. free ctx rct;
  3500. rc
  3501. ) in
  3502. let gather_implements() =
  3503. let classes = ref [] in
  3504. let rec lookup cv =
  3505. List.exists (fun (i,_) -> i == c || lookup i) cv.cl_implements
  3506. in
  3507. let check = function
  3508. | TClassDecl c when (has_class_flag c CInterface) = false && not (has_class_flag c CExtern) -> if lookup c then classes := c :: !classes
  3509. | _ -> ()
  3510. in
  3511. List.iter check ctx.com.types;
  3512. !classes
  3513. in
  3514. if (has_class_flag c CInterface) then begin
  3515. let l = gather_implements() in
  3516. let rt = alloc_tmp ctx HType in
  3517. op ctx (OType (rt, HType));
  3518. let ra = alloc_array ctx (reg_int ctx (List.length l)) HType in
  3519. list_iteri (fun i intf ->
  3520. op ctx (OType (rt, to_type ctx (TInst (intf,[]))));
  3521. op ctx (OSetArray (ra, reg_int ctx i, rt));
  3522. ) l;
  3523. op ctx (OSetField (rc,index "__implementedBy__",ra));
  3524. (* TODO : use a plain class for interface object since we don't allow statics *)
  3525. let rt = alloc_tmp ctx ct in
  3526. op ctx (OSafeCast (rt, rc));
  3527. op ctx (OSetGlobal (g, rt));
  3528. end;
  3529. (match Texpr.build_metadata ctx.com.basic (TClassDecl c) with
  3530. | None -> ()
  3531. | Some e ->
  3532. let r = eval_to ctx e HDyn in
  3533. op ctx (OSetField (rc,index "__meta__",r)));
  3534. free ctx rc;
  3535. | TEnumDecl e when not (has_enum_flag e EnExtern) ->
  3536. let et = enum_class ctx e in
  3537. let t = enum_type ctx e in
  3538. let ret = alloc_tmp ctx HType in
  3539. op ctx (OType (ret, et));
  3540. hold ctx ret;
  3541. let rt = alloc_tmp ctx HType in
  3542. op ctx (OType (rt, t));
  3543. let r = alloc_tmp ctx (class_type ctx ctx.base_enum [] false) in
  3544. op ctx (OCall2 (r, alloc_fun_path ctx ([],"Type") "initEnum", ret, rt));
  3545. free ctx ret;
  3546. let index name =
  3547. match et with
  3548. | HObj o ->
  3549. fst (try get_index name o with Not_found -> die "" __LOC__)
  3550. | _ ->
  3551. die "" __LOC__
  3552. in
  3553. let avalues = alloc_tmp ctx (HArray t) in
  3554. op ctx (OField (avalues, r, index "__evalues__"));
  3555. List.iter (fun n ->
  3556. let f = PMap.find n e.e_constrs in
  3557. match follow f.ef_type with
  3558. | TFun _ -> ()
  3559. | _ ->
  3560. let g = alloc_global ctx (efield_name e f) t in
  3561. let r = alloc_tmp ctx t in
  3562. let rd = alloc_tmp ctx HDyn in
  3563. op ctx (OGetArray (rd,avalues, reg_int ctx f.ef_index));
  3564. op ctx (OSafeCast (r, rd));
  3565. op ctx (OSetGlobal (g,r));
  3566. ) e.e_names;
  3567. (match Texpr.build_metadata ctx.com.basic (TEnumDecl e) with
  3568. | None -> ()
  3569. | Some e -> op ctx (OSetField (r,index "__meta__",eval_to ctx e HDyn)));
  3570. | TAbstractDecl { a_path = [], name; a_pos = pos } ->
  3571. (match name with
  3572. | "Int" | "Float" | "Dynamic" | "Bool" ->
  3573. let is_bool = name = "Bool" in
  3574. let t = class_type ctx (if is_bool then ctx.core_enum else ctx.core_type) [] false in
  3575. let index name =
  3576. match t with
  3577. | HObj o ->
  3578. fst (try get_index name o with Not_found -> die "" __LOC__)
  3579. | _ ->
  3580. die "" __LOC__
  3581. in
  3582. let g = alloc_global ctx ("$" ^ name) t in
  3583. let r = alloc_tmp ctx t in
  3584. let rt = alloc_tmp ctx HType in
  3585. op ctx (ONew r);
  3586. op ctx (OType (rt,(match name with "Int" -> HI32 | "Float" -> HF64 | "Dynamic" -> HDyn | "Bool" -> HBool | _ -> die "" __LOC__)));
  3587. op ctx (OSetField (r,index "__type__",rt));
  3588. op ctx (OSetField (r,index (if is_bool then "__ename__" else "__name__"),make_string ctx name pos));
  3589. op ctx (OSetGlobal (g,r));
  3590. let bytes = alloc_tmp ctx HBytes in
  3591. op ctx (OString (bytes, alloc_string ctx name));
  3592. op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx ([],"Type") "register",bytes,r));
  3593. | _ ->
  3594. ())
  3595. | _ ->
  3596. ()
  3597. ) types;
  3598. let j = jump ctx (fun d -> OJTrue (is_init,d)) in
  3599. op ctx (ORet (alloc_tmp ctx HVoid));
  3600. j();
  3601. free ctx is_init;
  3602. in
  3603. (* init class statics *)
  3604. let init_exprs = ref [] in
  3605. List.iter (fun t ->
  3606. (match t with TClassDecl { cl_init = Some {cf_expr = Some e} } -> init_exprs := e :: !init_exprs | _ -> ());
  3607. match t with
  3608. | TClassDecl c when not (has_class_flag c CExtern) ->
  3609. List.iter (fun f ->
  3610. match f.cf_kind, f.cf_expr with
  3611. | Var _, Some e ->
  3612. let p = e.epos in
  3613. let e = mk (TBinop (OpAssign,(mk (TField (mk (TTypeExpr t) t_dynamic p,FStatic (c,f))) f.cf_type p), e)) f.cf_type p in
  3614. exprs := e :: !exprs;
  3615. | _ ->
  3616. ()
  3617. ) c.cl_ordered_statics;
  3618. | _ -> ()
  3619. ) types;
  3620. (* call main() *)
  3621. (match main with
  3622. | None -> ()
  3623. | Some e -> exprs := e :: !exprs);
  3624. let fid = lookup_alloc ctx.cfids () in
  3625. let exprs = List.rev !init_exprs @ List.rev !exprs in
  3626. ignore(make_fun ~gen_content ctx ("","") fid { tf_expr = mk (TBlock exprs) t_void null_pos; tf_args = []; tf_type = t_void } None None);
  3627. fid
  3628. (* --------------------------------------------------------------------------------------------------------------------- *)
  3629. (* WRITE *)
  3630. (* from -500M to +500M
  3631. 0[7] = 0-127
  3632. 10[+/-][5] [8] = -x2000/+x2000
  3633. 11[+/-][5] [24] = -x20000000/+x20000000
  3634. *)
  3635. let write_index_gen b i =
  3636. if i < 0 then
  3637. let i = -i in
  3638. if i < 0x2000 then begin
  3639. b ((i lsr 8) lor 0xA0);
  3640. b (i land 0xFF);
  3641. end else if i >= 0x20000000 then die "" __LOC__ else begin
  3642. b ((i lsr 24) lor 0xE0);
  3643. b ((i lsr 16) land 0xFF);
  3644. b ((i lsr 8) land 0xFF);
  3645. b (i land 0xFF);
  3646. end
  3647. else if i < 0x80 then
  3648. b i
  3649. else if i < 0x2000 then begin
  3650. b ((i lsr 8) lor 0x80);
  3651. b (i land 0xFF);
  3652. end else if i >= 0x20000000 then die "" __LOC__ else begin
  3653. b ((i lsr 24) lor 0xC0);
  3654. b ((i lsr 16) land 0xFF);
  3655. b ((i lsr 8) land 0xFF);
  3656. b (i land 0xFF);
  3657. end
  3658. let write_code ch code debug =
  3659. let all_types, htypes = gather_types code in
  3660. let byte = IO.write_byte ch in
  3661. let write_index = write_index_gen byte in
  3662. let write_type t =
  3663. write_index (try PMap.find t htypes with Not_found -> die (tstr t) __LOC__)
  3664. in
  3665. let write_op op =
  3666. let o = Obj.repr op in
  3667. let oid = Obj.tag o in
  3668. match op with
  3669. | OLabel _ | ONop _ | OAssert _ ->
  3670. byte oid
  3671. | OCall2 (r,g,a,b) ->
  3672. byte oid;
  3673. write_index r;
  3674. write_index g;
  3675. write_index a;
  3676. write_index b;
  3677. | OCall3 (r,g,a,b,c) ->
  3678. byte oid;
  3679. write_index r;
  3680. write_index g;
  3681. write_index a;
  3682. write_index b;
  3683. write_index c;
  3684. | OCall4 (r,g,a,b,c,d) ->
  3685. byte oid;
  3686. write_index r;
  3687. write_index g;
  3688. write_index a;
  3689. write_index b;
  3690. write_index c;
  3691. write_index d;
  3692. | OCallN (r,f,rl) | OCallClosure (r,f,rl) | OCallMethod (r,f,rl) | OCallThis (r,f,rl) | OMakeEnum (r,f,rl) ->
  3693. byte oid;
  3694. write_index r;
  3695. write_index f;
  3696. let n = List.length rl in
  3697. if n > 0xFF then die "" __LOC__;
  3698. byte n;
  3699. List.iter write_index rl
  3700. | OType (r,t) ->
  3701. byte oid;
  3702. write_index r;
  3703. write_type t
  3704. | OSwitch (r,pl,eend) ->
  3705. byte oid;
  3706. write_index r;
  3707. write_index (Array.length pl);
  3708. Array.iter write_index pl;
  3709. write_index eend
  3710. | OEnumField (r,e,i,idx) ->
  3711. byte oid;
  3712. write_index r;
  3713. write_index e;
  3714. write_index i;
  3715. write_index idx;
  3716. | _ ->
  3717. let field n = (Obj.magic (Obj.field o n) : int) in
  3718. match Obj.size o with
  3719. | 1 ->
  3720. let a = field 0 in
  3721. byte oid;
  3722. write_index a;
  3723. | 2 ->
  3724. let a = field 0 in
  3725. let b = field 1 in
  3726. byte oid;
  3727. write_index a;
  3728. write_index b;
  3729. | 3 ->
  3730. let a = field 0 in
  3731. let b = field 1 in
  3732. let c = field 2 in
  3733. byte oid;
  3734. write_index a;
  3735. write_index b;
  3736. write_index c;
  3737. | _ ->
  3738. die "" __LOC__
  3739. in
  3740. IO.nwrite_string ch "HLB";
  3741. byte code.version;
  3742. let flags = ref 0 in
  3743. if debug then flags := !flags lor 1;
  3744. byte !flags;
  3745. write_index (Array.length code.ints);
  3746. write_index (Array.length code.floats);
  3747. write_index (Array.length code.strings);
  3748. if code.version >= 5 then write_index (Array.length code.bytes);
  3749. write_index (Array.length all_types);
  3750. write_index (Array.length code.globals);
  3751. write_index (Array.length code.natives);
  3752. write_index (Array.length code.functions);
  3753. write_index (Array.length code.constants);
  3754. write_index code.entrypoint;
  3755. Array.iter (IO.write_real_i32 ch) code.ints;
  3756. Array.iter (IO.write_double ch) code.floats;
  3757. let write_strings strings =
  3758. let str_length = ref 0 in
  3759. Array.iter (fun str -> str_length := !str_length + String.length str + 1) strings;
  3760. IO.write_i32 ch !str_length;
  3761. Array.iter (IO.write_string ch) strings;
  3762. Array.iter (fun str -> write_index (String.length str)) strings;
  3763. in
  3764. write_strings code.strings;
  3765. let write_bytes bytes =
  3766. let bytes_length = ref 0 in
  3767. Array.iter (fun b -> bytes_length := !bytes_length + Bytes.length b) bytes;
  3768. IO.write_i32 ch !bytes_length;
  3769. Array.iter (IO.nwrite ch) bytes;
  3770. let bytes_pos = ref 0 in
  3771. Array.iter (fun b ->
  3772. write_index (!bytes_pos);
  3773. bytes_pos := !bytes_pos + Bytes.length b
  3774. ) bytes;
  3775. in
  3776. if code.version >= 5 then write_bytes code.bytes;
  3777. if debug then begin
  3778. write_index (Array.length code.debugfiles);
  3779. write_strings code.debugfiles;
  3780. end;
  3781. Array.iter (fun t ->
  3782. match t with
  3783. | HVoid -> byte 0
  3784. | HUI8 -> byte 1
  3785. | HUI16 -> byte 2
  3786. | HI32 -> byte 3
  3787. | HI64 -> byte 4
  3788. | HF32 -> byte 5
  3789. | HF64 -> byte 6
  3790. | HBool -> byte 7
  3791. | HBytes -> byte 8
  3792. | HDyn -> byte 9
  3793. | HFun (args,ret) | HMethod (args,ret) ->
  3794. let n = List.length args in
  3795. if n > 0xFF then die "" __LOC__;
  3796. byte (match t with HFun _ -> 10 | _ -> 20);
  3797. byte n;
  3798. List.iter write_type args;
  3799. write_type ret
  3800. | HObj p | HStruct p ->
  3801. byte (if is_struct t then 21 else 11);
  3802. write_index p.pid;
  3803. (match p.psuper with
  3804. | None -> write_index (-1)
  3805. | Some tsup -> write_type (match t with HObj _ -> HObj tsup | _ -> HStruct tsup));
  3806. (match p.pclassglobal with
  3807. | None -> write_index 0
  3808. | Some g -> write_index (g + 1));
  3809. write_index (Array.length p.pfields);
  3810. write_index (Array.length p.pproto);
  3811. write_index (List.length p.pbindings);
  3812. Array.iter (fun (_,n,t) -> write_index n; write_type t) p.pfields;
  3813. Array.iter (fun f -> write_index f.fid; write_index f.fmethod; write_index (match f.fvirtual with None -> -1 | Some i -> i)) p.pproto;
  3814. List.iter (fun (fid,fidx) -> write_index fid; write_index fidx) p.pbindings;
  3815. | HArray _ ->
  3816. byte 12
  3817. | HType ->
  3818. byte 13
  3819. | HRef t ->
  3820. byte 14;
  3821. write_type t
  3822. | HVirtual v ->
  3823. byte 15;
  3824. write_index (Array.length v.vfields);
  3825. Array.iter (fun (_,sid,t) -> write_index sid; write_type t) v.vfields
  3826. | HDynObj ->
  3827. byte 16
  3828. | HAbstract (_,i) ->
  3829. byte 17;
  3830. write_index i
  3831. | HEnum e ->
  3832. byte 18;
  3833. write_index e.eid;
  3834. (match e.eglobal with
  3835. | None -> write_index 0
  3836. | Some g -> write_index (g + 1));
  3837. write_index (Array.length e.efields);
  3838. Array.iter (fun (_,nid,tl) ->
  3839. write_index nid;
  3840. if Array.length tl > 0xFF then die "" __LOC__;
  3841. byte (Array.length tl);
  3842. Array.iter write_type tl;
  3843. ) e.efields
  3844. | HNull t ->
  3845. byte 19;
  3846. write_type t
  3847. | HPacked t ->
  3848. byte 22;
  3849. write_type t
  3850. ) all_types;
  3851. let write_debug_infos debug =
  3852. let curfile = ref (-1) in
  3853. let curpos = ref 0 in
  3854. let rcount = ref 0 in
  3855. let rec flush_repeat p =
  3856. if !rcount > 0 then begin
  3857. if !rcount > 15 then begin
  3858. byte ((15 lsl 2) lor 2);
  3859. rcount := !rcount - 15;
  3860. flush_repeat(p)
  3861. end else begin
  3862. let delta = p - !curpos in
  3863. let delta = (if delta > 0 && delta < 4 then delta else 0) in
  3864. byte ((delta lsl 6) lor (!rcount lsl 2) lor 2);
  3865. rcount := 0;
  3866. curpos := !curpos + delta;
  3867. end
  3868. end
  3869. in
  3870. Array.iter (fun (f,p,_) ->
  3871. if f <> !curfile then begin
  3872. flush_repeat(p);
  3873. curfile := f;
  3874. byte ((f lsr 7) lor 1);
  3875. byte (f land 0xFF);
  3876. end;
  3877. if p <> !curpos then flush_repeat(p);
  3878. if p = !curpos then
  3879. rcount := !rcount + 1
  3880. else
  3881. let delta = p - !curpos in
  3882. if delta > 0 && delta < 32 then
  3883. byte ((delta lsl 3) lor 4)
  3884. else begin
  3885. byte (p lsl 3);
  3886. byte (p lsr 5);
  3887. byte (p lsr 13);
  3888. end;
  3889. curpos := p;
  3890. ) debug;
  3891. flush_repeat(!curpos)
  3892. in
  3893. Array.iter write_type code.globals;
  3894. Array.iter (fun (lib_index, name_index,ttype,findex) ->
  3895. write_index lib_index;
  3896. write_index name_index;
  3897. write_type ttype;
  3898. write_index findex;
  3899. ) code.natives;
  3900. Array.iter (fun f ->
  3901. write_type f.ftype;
  3902. write_index f.findex;
  3903. write_index (Array.length f.regs);
  3904. write_index (Array.length f.code);
  3905. Array.iter write_type f.regs;
  3906. Array.iter write_op f.code;
  3907. if debug then begin
  3908. write_debug_infos f.debug;
  3909. write_index (Array.length f.assigns);
  3910. Array.iter (fun (i,p) ->
  3911. write_index i;
  3912. write_index (p + 1);
  3913. ) f.assigns;
  3914. end;
  3915. ) code.functions;
  3916. Array.iter (fun (g,fields) ->
  3917. write_index g;
  3918. write_index (Array.length fields);
  3919. Array.iter write_index fields;
  3920. ) code.constants
  3921. (* --------------------------------------------------------------------------------------------------------------------- *)
  3922. let create_context com dump =
  3923. let get_type name =
  3924. try
  3925. List.find (fun t -> (t_infos t).mt_path = (["hl"],name)) com.types
  3926. with Not_found -> try
  3927. List.find (fun t -> (t_infos t).mt_path = (["hl";"types"],name)) com.types
  3928. with Not_found ->
  3929. failwith ("hl type " ^ name ^ " not found")
  3930. in
  3931. let get_class name =
  3932. match get_type name with
  3933. | TClassDecl c -> c
  3934. | _ -> die "" __LOC__
  3935. in
  3936. let get_abstract name =
  3937. match get_type name with
  3938. | TAbstractDecl a -> a
  3939. | _ -> die "" __LOC__
  3940. in
  3941. let ctx = {
  3942. com = com;
  3943. optimize = not (Common.raw_defined com "hl_no_opt");
  3944. w_null_compare = Common.raw_defined com "hl_w_null_compare";
  3945. dump_out = if dump then Some (IO.output_channel (open_out_bin "dump/hlopt.txt")) else None;
  3946. m = method_context 0 HVoid null_capture false;
  3947. cints = new_lookup();
  3948. cstrings = new_lookup();
  3949. cbytes = new_lookup();
  3950. cfloats = new_lookup();
  3951. cglobals = new_lookup();
  3952. cnatives = new_lookup();
  3953. cconstants = new_lookup();
  3954. cfunctions = DynArray.create();
  3955. overrides = Hashtbl.create 0;
  3956. cached_types = PMap.empty;
  3957. cached_tuples = PMap.empty;
  3958. cfids = new_lookup();
  3959. defined_funs = Hashtbl.create 0;
  3960. tstring = HVoid;
  3961. array_impl = {
  3962. aall = get_class "ArrayAccess";
  3963. abase = get_class "ArrayBase";
  3964. adyn = get_class "ArrayDyn";
  3965. aobj = get_class "ArrayObj";
  3966. aui16 = get_class "ArrayBytes_hl_UI16";
  3967. ai32 = get_class "ArrayBytes_Int";
  3968. af32 = get_class "ArrayBytes_hl_F32";
  3969. af64 = get_class "ArrayBytes_Float";
  3970. ai64 = get_class "ArrayBytes_hl_I64";
  3971. };
  3972. base_class = get_class "Class";
  3973. base_enum = get_class "Enum";
  3974. base_type = get_class "BaseType";
  3975. core_type = get_class "CoreType";
  3976. core_enum = get_class "CoreEnum";
  3977. ref_abstract = get_abstract "Ref";
  3978. anons_cache = PMap.empty;
  3979. rec_cache = [];
  3980. method_wrappers = PMap.empty;
  3981. cdebug_files = new_lookup();
  3982. macro_typedefs = Hashtbl.create 0;
  3983. ct_delayed = [];
  3984. ct_depth = 0;
  3985. } in
  3986. ctx.tstring <- to_type ctx ctx.com.basic.tstring;
  3987. ignore(alloc_string ctx "");
  3988. ignore(class_type ctx ctx.base_class [] false);
  3989. ctx
  3990. let add_types ctx types =
  3991. List.iter (fun t ->
  3992. match t with
  3993. | TClassDecl ({ cl_path = ["hl";"types"], ("BytesIterator"|"BytesKeyValueIterator"|"ArrayBytes") } as c) ->
  3994. add_class_flag c CExtern
  3995. | TClassDecl c ->
  3996. let rec loop p f =
  3997. match p with
  3998. | Some (p,_) when PMap.mem f.cf_name p.cl_fields || loop p.cl_super f ->
  3999. Hashtbl.replace ctx.overrides (f.cf_name,p.cl_path) true;
  4000. true
  4001. | _ ->
  4002. false
  4003. in
  4004. List.iter (fun f -> if has_class_field_flag f CfOverride then ignore(loop c.cl_super f)) c.cl_ordered_fields;
  4005. List.iter (fun (m,args,p) ->
  4006. if m = Meta.HlNative then
  4007. let lib, prefix = (match args with
  4008. | [(EConst (String(lib,_)),_)] -> lib, ""
  4009. | [(EConst (String(lib,_)),_);(EConst (String(p,_)),_)] -> lib, p
  4010. | _ -> abort "hlNative on class requires library name" p
  4011. ) in
  4012. (* adds :hlNative for all empty methods *)
  4013. List.iter (fun f ->
  4014. match f.cf_kind with
  4015. | Method MethNormal when not (List.exists (fun (m,_,_) -> m = Meta.HlNative) f.cf_meta) ->
  4016. (match f.cf_expr with
  4017. | Some { eexpr = TFunction { tf_expr = { eexpr = TBlock ([] | [{ eexpr = TReturn (Some { eexpr = TConst _ })}]) } } } | None ->
  4018. let name = prefix ^ String.lowercase_ascii (Str.global_replace (Str.regexp "[A-Z]+") "_\\0" f.cf_name) in
  4019. f.cf_meta <- (Meta.HlNative, [(EConst (String(lib,SDoubleQuotes)),p);(EConst (String(name,SDoubleQuotes)),p)], p) :: f.cf_meta;
  4020. | _ -> ())
  4021. | _ -> ()
  4022. ) c.cl_ordered_statics
  4023. ) c.cl_meta;
  4024. | _ -> ()
  4025. ) types;
  4026. List.iter (generate_type ctx) types
  4027. let build_code ctx types main =
  4028. let ep = generate_static_init ctx types main in
  4029. let bytes = DynArray.to_array ctx.cbytes.arr in
  4030. {
  4031. version = if Array.length bytes = 0 then 4 else 5;
  4032. entrypoint = ep;
  4033. strings = DynArray.to_array ctx.cstrings.arr;
  4034. bytes = bytes;
  4035. ints = DynArray.to_array ctx.cints.arr;
  4036. floats = DynArray.to_array ctx.cfloats.arr;
  4037. globals = DynArray.to_array ctx.cglobals.arr;
  4038. natives = DynArray.to_array ctx.cnatives.arr;
  4039. functions = DynArray.to_array ctx.cfunctions;
  4040. debugfiles = DynArray.to_array ctx.cdebug_files.arr;
  4041. constants = DynArray.to_array ctx.cconstants.arr;
  4042. }
  4043. let check ctx =
  4044. PMap.iter (fun (s,p) fid ->
  4045. if not (Hashtbl.mem ctx.defined_funs fid) then failwith (Printf.sprintf "Unresolved method %s:%s(@%d)" (s_type_path p) s fid)
  4046. ) ctx.cfids.map
  4047. let make_context_sign com =
  4048. let mhash = Hashtbl.create 0 in
  4049. List.iter (fun t ->
  4050. let mt = t_infos t in
  4051. let mid = mt.mt_module.m_id in
  4052. Hashtbl.add mhash mid true
  4053. ) com.types;
  4054. let data = Marshal.to_string mhash [No_sharing] in
  4055. Digest.to_hex (Digest.string data)
  4056. let prev_sign = ref "" and prev_data = ref ""
  4057. let generate com =
  4058. let dump = Common.defined com Define.Dump in
  4059. let hl_check = Common.raw_defined com "hl_check" in
  4060. let sign = make_context_sign com in
  4061. if sign = !prev_sign && not dump && not hl_check then begin
  4062. (* reuse previously generated data *)
  4063. let ch = open_out_bin com.file in
  4064. output_string ch !prev_data;
  4065. close_out ch;
  4066. end else
  4067. let ctx = create_context com dump in
  4068. add_types ctx com.types;
  4069. let code = build_code ctx com.types com.main.main_expr in
  4070. Array.sort (fun (lib1,_,_,_) (lib2,_,_,_) -> lib1 - lib2) code.natives;
  4071. if dump then begin
  4072. (match ctx.dump_out with None -> () | Some ch -> IO.close_out ch);
  4073. let ch = open_out_bin "dump/hlcode.txt" in
  4074. Hlcode.dump (fun s -> output_string ch (s ^ "\n")) code;
  4075. close_out ch;
  4076. end;
  4077. (*if Common.raw_defined com "hl_dump_spec" then begin
  4078. let ch = open_out_bin "dump/hlspec.txt" in
  4079. let write s = output_string ch (s ^ "\n") in
  4080. Array.iter (fun f ->
  4081. write (fundecl_name f);
  4082. let spec = Hlinterp.make_spec code f in
  4083. List.iter (fun s -> write ("\t" ^ Hlinterp.spec_string s)) spec;
  4084. write "";
  4085. ) code.functions;
  4086. close_out ch;
  4087. end;*)
  4088. if hl_check then begin
  4089. check ctx;
  4090. Hlinterp.check com.error code;
  4091. end;
  4092. let t = Timer.timer ["generate";"hl";"write"] in
  4093. let escape_command s =
  4094. let b = Buffer.create 0 in
  4095. String.iter (fun ch -> if (ch=='"' || ch=='\\' ) then Buffer.add_string b "\\"; Buffer.add_char b ch) s;
  4096. "\"" ^ Buffer.contents b ^ "\""
  4097. in
  4098. if Path.file_extension com.file = "c" then begin
  4099. let gnames = Array.make (Array.length code.globals) "" in
  4100. PMap.iter (fun n i -> gnames.(i) <- n) ctx.cglobals.map;
  4101. if not (Common.defined com Define.SourceHeader) then begin
  4102. let version_major = com.version / 1000 in
  4103. let version_minor = (com.version mod 1000) / 100 in
  4104. let version_revision = (com.version mod 100) in
  4105. Common.define_value com Define.SourceHeader (Printf.sprintf "Generated by HLC %d.%d.%d (HL v%d)" version_major version_minor version_revision code.version);
  4106. end;
  4107. Hl2c.write_c com com.file code gnames;
  4108. let t = Timer.timer ["nativecompile";"hl"] in
  4109. if not (Common.defined com Define.NoCompilation) && com.run_command_args "haxelib" ["run";"hashlink";"build";escape_command com.file] <> 0 then failwith "Build failed";
  4110. t();
  4111. end else begin
  4112. let ch = IO.output_string() in
  4113. write_code ch code (not (Common.raw_defined com "hl_no_debug"));
  4114. let str = IO.close_out ch in
  4115. let ch = open_out_bin com.file in
  4116. output_string ch str;
  4117. close_out ch;
  4118. prev_sign := sign;
  4119. prev_data := str;
  4120. end;
  4121. Hlopt.clean_cache();
  4122. t();
  4123. if Common.raw_defined com "run" then begin
  4124. if com.run_command_args "haxelib" ["run";"hashlink";"run";escape_command com.file] <> 0 then failwith "Failed to run HL";
  4125. end;
  4126. if Common.defined com Define.Interp then
  4127. try
  4128. let t = Timer.timer ["generate";"hl";"interp"] in
  4129. let ctx = Hlinterp.create true in
  4130. Hlinterp.add_code ctx code;
  4131. t();
  4132. with
  4133. Failure msg -> abort msg null_pos