genhl.ml 127 KB

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