123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329 |
- (*
- * Copyright (C)2005-2015 Haxe Foundation
- *
- * Permission is hereby granted, free of charge, to any person obtaining a
- * copy of this software and associated documentation files (the "Software"),
- * to deal in the Software without restriction, including without limitation
- * the rights to use, copy, modify, merge, publish, distribute, sublicense,
- * and/or sell copies of the Software, and to permit persons to whom the
- * Software is furnished to do so, subject to the following conditions:
- *
- * The above copyright notice and this permission notice shall be included in
- * all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
- * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
- * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
- * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
- * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
- * DEALINGS IN THE SOFTWARE.
- *)
- open Extlib_leftovers
- open Globals
- open Ast
- open Type
- open Error
- open Common
- open Hlcode
- (* compiler *)
- type ('a,'b) lookup = {
- arr : 'b DynArray.t;
- mutable map : ('a, int) PMap.t;
- }
- (* not mutable, might be be shared *)
- type method_capture = {
- c_map : (int, int) PMap.t;
- c_vars : tvar array;
- c_type : ttype;
- c_group : bool;
- }
- type allocator = {
- mutable a_all : int list;
- mutable a_hold : int list;
- }
- type lassign = (string index * int)
- type method_context = {
- mid : int;
- mregs : (int, ttype) lookup;
- mops : opcode DynArray.t;
- mret : ttype;
- mdebug : Globals.pos DynArray.t;
- mvars : (int, int) Hashtbl.t;
- mhasthis : bool;
- mutable mdeclared : int list;
- mutable mallocs : (ttype, allocator) PMap.t;
- mutable mcaptured : method_capture;
- mutable mcontinues : (int -> unit) list;
- mutable mbreaks : (int -> unit) list;
- mutable mtrys : int;
- mutable mloop_trys : int;
- mutable mcaptreg : int;
- mutable mcurpos : Globals.pos;
- mutable massign : lassign list;
- }
- type array_impl = {
- aall : tclass;
- abase : tclass;
- adyn : tclass;
- aobj : tclass;
- aui16 : tclass;
- ai32 : tclass;
- af32 : tclass;
- af64 : tclass;
- ai64 : tclass;
- }
- type constval =
- | CString of string
- type context = {
- com : Common.context;
- cglobals : (string, ttype) lookup;
- cstrings : (string, string) lookup;
- cbytes : (bytes, bytes) lookup;
- cfloats : (float, float) lookup;
- cints : (int32, int32) lookup;
- cnatives : (string * int, (string index * string index * ttype * functable index)) lookup;
- cfids : (string * path, unit) lookup;
- cfunctions : fundecl DynArray.t;
- cconstants : (constval, (global * int array)) lookup;
- optimize : bool;
- w_null_compare : bool;
- overrides : (string * path, bool) Hashtbl.t;
- defined_funs : (int,unit) Hashtbl.t;
- mutable dump_out : (unit IO.output) option;
- mutable cached_types : (string list, ttype) PMap.t;
- mutable m : method_context;
- mutable anons_cache : (tanon, ttype) PMap.t;
- mutable method_wrappers : ((ttype * ttype), int) PMap.t;
- mutable rec_cache : (Type.t * ttype option ref) list;
- mutable cached_tuples : (ttype list, ttype) PMap.t;
- mutable tstring : ttype;
- macro_typedefs : (string, ttype) Hashtbl.t;
- array_impl : array_impl;
- base_class : tclass;
- base_type : tclass;
- base_enum : tclass;
- core_type : tclass;
- core_enum : tclass;
- ref_abstract : tabstract;
- cdebug_files : (string, string) lookup;
- mutable ct_delayed : (unit -> unit) list;
- mutable ct_depth : int;
- }
- (* --- *)
- type access =
- | ANone
- | AGlobal of global
- | ALocal of tvar * reg
- | AStaticVar of global * ttype * field index
- | AStaticFun of fundecl index
- | AInstanceFun of texpr * fundecl index
- | AInstanceProto of texpr * field index
- | AInstanceField of texpr * field index
- | AArray of reg * (ttype * ttype) * reg
- | ACArray of reg * ttype * reg
- | AVirtualMethod of texpr * field index
- | ADynamic of texpr * string index
- | AEnum of tenum * field index
- | ACaptured of field index
- let is_to_string t =
- match follow t with
- | TFun([],r) -> (match follow r with TInst({ cl_path=[],"String" },[]) -> true | _ -> false)
- | _ -> false
- let is_string = function
- | HObj { pname = "String"} -> true
- | _ -> false
- let is_extern_field f =
- 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
- let is_array_class name =
- match name with
- | "hl.types.ArrayDyn" | "hl.types.ArrayBytes_Int" | "hl.types.ArrayBytes_Float" | "hl.types.ArrayObj" | "hl.types.ArrayBytes_hl_F32" | "hl.types.ArrayBytes_hl_UI16" | "hl.types.ArrayBytes_hl_I64" -> true
- | _ -> false
- let is_array_type t =
- match t with
- | HObj p -> is_array_class p.pname
- | _ -> false
- let max_pos e =
- let p = e.epos in
- { p with pmin = p.pmax }
- let to_utf8 str p =
- let u8 = try
- UTF8.validate str;
- str;
- with
- UTF8.Malformed_code ->
- (* ISO to utf8 *)
- let b = UTF8.Buf.create 0 in
- String.iter (fun c -> UTF8.Buf.add_char b (UCharExt.of_char c)) str;
- UTF8.Buf.contents b
- in
- let ccount = ref 0 in
- UTF8.iter (fun c ->
- let c = UCharExt.code c in
- if (c >= 0xD800 && c <= 0xDFFF) || c >= 0x110000 then abort "Invalid unicode char" p;
- incr ccount;
- if c >= 0x10000 then incr ccount;
- ) u8;
- u8, !ccount
- let tuple_type ctx tl =
- try
- PMap.find tl ctx.cached_tuples
- with Not_found ->
- let ct = HEnum {
- eglobal = None;
- ename = "";
- eid = 0;
- efields = [|"",0,Array.of_list tl|];
- } in
- ctx.cached_tuples <- PMap.add tl ct ctx.cached_tuples;
- ct
- let type_size_bits = function
- | HUI8 | HBool -> 0
- | HUI16 -> 1
- | HI32 | HF32 -> 2
- | HI64 | HF64 -> 3
- | _ -> die "" __LOC__
- let new_lookup() =
- {
- arr = DynArray.create();
- map = PMap.empty;
- }
- let null_capture =
- {
- c_vars = [||];
- c_map = PMap.empty;
- c_type = HVoid;
- c_group = false;
- }
- let lookup l v fb =
- try
- PMap.find v l.map
- with Not_found ->
- let id = DynArray.length l.arr in
- DynArray.add l.arr (Obj.magic 0);
- l.map <- PMap.add v id l.map;
- DynArray.set l.arr id (fb());
- id
- let lookup_alloc l v =
- let id = DynArray.length l.arr in
- DynArray.add l.arr v;
- id
- let method_context id t captured hasthis =
- {
- mid = id;
- mregs = new_lookup();
- mops = DynArray.create();
- mvars = Hashtbl.create 0;
- mallocs = PMap.empty;
- mret = t;
- mbreaks = [];
- mdeclared = [];
- mcontinues = [];
- mhasthis = hasthis;
- mcaptured = captured;
- mtrys = 0;
- mloop_trys = 0;
- mcaptreg = 0;
- mdebug = DynArray.create();
- mcurpos = Globals.null_pos;
- massign = [];
- }
- let field_name c f =
- s_type_path c.cl_path ^ ":" ^ f.cf_name
- let efield_name e f =
- s_type_path e.e_path ^ ":" ^ f.ef_name
- let global_type ctx g =
- DynArray.get ctx.cglobals.arr g
- let is_overridden ctx c f =
- Hashtbl.mem ctx.overrides (f.cf_name,c.cl_path)
- let alloc_float ctx f =
- lookup ctx.cfloats f (fun() -> f)
- let alloc_i32 ctx i =
- lookup ctx.cints i (fun() -> i)
- let alloc_string ctx s =
- lookup ctx.cstrings s (fun() -> s)
- let alloc_bytes ctx s =
- lookup ctx.cbytes s (fun() -> s)
- let array_class ctx t =
- match t with
- | HI32 ->
- ctx.array_impl.ai32
- | HUI16 ->
- ctx.array_impl.aui16
- | HF32 ->
- ctx.array_impl.af32
- | HF64 ->
- ctx.array_impl.af64
- | HI64 ->
- ctx.array_impl.ai64
- | HDyn ->
- ctx.array_impl.adyn
- | _ ->
- ctx.array_impl.aobj
- let member_fun c t =
- match follow t with
- | TFun (args, ret) -> TFun (("this",false,TInst(c,[])) :: args, ret)
- | _ -> die "" __LOC__
- let rec unsigned t =
- match follow t with
- | TAbstract ({ a_path = [],"UInt" },_) -> true
- | TAbstract (a,pl) -> unsigned (Abstract.get_underlying_type a pl)
- | _ -> false
- let unsigned_op e1 e2 =
- let is_unsigned e =
- match e.eexpr with
- | TConst (TInt _) -> true
- | _ -> unsigned e.etype
- in
- is_unsigned e1 && is_unsigned e2
- let rec get_const e =
- match e.eexpr with
- | TConst c -> c
- | TParenthesis e | TCast (e,_) -> get_const e
- | _ -> abort "Should be a constant" e.epos
- let set_curpos ctx p =
- ctx.m.mcurpos <- p
- let make_debug ctx arr =
- let get_relative_path p =
- match Common.defined ctx.com Common.Define.AbsolutePath with
- | true -> if (Filename.is_relative p.pfile)
- then Filename.concat (Sys.getcwd()) p.pfile
- else p.pfile
- | false -> try
- (* lookup relative path *)
- let len = String.length p.pfile in
- let base = ctx.com.class_paths#find (fun path ->
- let path = path#path in
- let l = String.length path in
- len > l && String.sub p.pfile 0 l = path
- ) in
- let l = String.length base#path in
- String.sub p.pfile l (len - l)
- with Not_found ->
- p.pfile
- in
- let pos = ref (0,0,Globals.null_pos) in
- let cur_file = ref 0 in
- let cur_line = ref 0 in
- let cur = ref Globals.null_pos in
- let out = Array.make (DynArray.length arr) !pos in
- for i = 0 to DynArray.length arr - 1 do
- let p = DynArray.unsafe_get arr i in
- if p != !cur then begin
- let file = if p.pfile == (!cur).pfile then !cur_file else lookup ctx.cdebug_files p.pfile (fun() -> get_relative_path p) in
- let line = Lexer.get_error_line p in
- if line <> !cur_line || file <> !cur_file then begin
- cur_file := file;
- cur_line := line;
- pos := (file,line,p);
- end;
- cur := p;
- end;
- Array.unsafe_set out i !pos
- done;
- out
- let fake_tnull =
- {null_abstract with
- a_path = [],"Null";
- a_params = [mk_type_param null_class TPHType None None];
- }
- let get_rec_cache ctx t none_callback not_found_callback =
- try
- match !(List.assq t ctx.rec_cache) with
- | None -> none_callback()
- | Some t -> t
- with Not_found ->
- let tref = ref None in
- ctx.rec_cache <- (t,tref) :: ctx.rec_cache;
- let t = not_found_callback tref in
- ctx.rec_cache <- List.tl ctx.rec_cache;
- t
- let rec to_type ?tref ctx t =
- match t with
- | TMono r ->
- (match r.tm_type with
- | None -> HDyn
- | Some t -> to_type ?tref ctx t)
- | TType (td,tl) ->
- let t =
- get_rec_cache ctx t
- (fun() -> abort "Unsupported recursive type" td.t_pos)
- (fun tref -> to_type ~tref ctx (apply_typedef td tl))
- in
- (match td.t_path with
- | ["haxe";"macro"], name -> Hashtbl.replace ctx.macro_typedefs name t; t
- | _ -> t)
- | TLazy f ->
- to_type ?tref ctx (lazy_type f)
- | TFun (args, ret) ->
- HFun (List.map (fun (_,o,t) ->
- let pt = to_type ctx t in
- if o && not (is_nullable pt) then HRef pt else pt
- ) args, to_type ctx ret)
- | TAnon a when (match !(a.a_status) with ClassStatics _ | EnumStatics _ -> true | _ -> false) ->
- (match !(a.a_status) with
- | ClassStatics c ->
- class_type ctx c (extract_param_types c.cl_params) true
- | EnumStatics e ->
- enum_class ctx e
- | _ -> die "" __LOC__)
- | TAnon a ->
- if PMap.is_empty a.a_fields then HDyn else
- (try
- (* can't use physical comparison in PMap since addresses might change in GC compact,
- maybe add an uid to tanon if too slow ? *)
- PMap.find a ctx.anons_cache
- with Not_found ->
- let vp = {
- vfields = [||];
- vindex = PMap.empty;
- } in
- let t = HVirtual vp in
- (match tref with
- | None -> ()
- | Some r -> r := Some t);
- ctx.anons_cache <- PMap.add a t ctx.anons_cache;
- let fields = PMap.fold (fun cf acc -> cfield_type ctx cf :: acc) a.a_fields [] in
- let fields = List.sort (fun (n1,_,_) (n2,_,_) -> compare n1 n2) fields in
- vp.vfields <- Array.of_list fields;
- Array.iteri (fun i (n,_,_) -> vp.vindex <- PMap.add n i vp.vindex) vp.vfields;
- t
- )
- | TDynamic _ ->
- HDyn
- | TEnum (e,_) ->
- enum_type ~tref ctx e
- | TInst ({ cl_path = ["hl"],"Abstract" },[TInst({ cl_kind = KExpr (EConst (String(name,_)),_) },_)]) ->
- HAbstract (name, alloc_string ctx name)
- | TInst (c,pl) ->
- (match c.cl_kind with
- | KTypeParameter ttp ->
- let rec loop = function
- | [] -> HDyn
- | t :: tl ->
- match follow (apply_params c.cl_params pl t) with
- | TInst (c,_) as t when not (has_class_flag c CInterface) -> to_type ?tref ctx t
- | _ -> loop tl
- in
- loop (get_constraints ttp)
- | _ -> class_type ~tref ctx c pl false)
- | TAbstract ({a_path = [],"Null"},[t1]) ->
- let t = to_type ?tref ctx t1 in
- if not (is_nullable t) && t <> HVoid then HNull t else t
- | TAbstract (a,pl) ->
- if Meta.has Meta.CoreType a.a_meta then
- (match a.a_path with
- | [], "Void" -> HVoid
- | [], "Int" | [], "UInt" -> HI32
- | [], "Float" -> HF64
- | [], "Single" -> HF32
- | [], "Bool" -> HBool
- | [], "Dynamic" -> HDyn
- | [], "Class" ->
- class_type ctx ctx.base_class [] false
- | [], "Enum" ->
- class_type ctx ctx.base_type [] false
- | [], "EnumValue" -> HDyn
- | ["hl"], "Ref" -> HRef (to_type ctx (List.hd pl))
- | ["hl"], ("Bytes" | "BytesAccess") -> HBytes
- | ["hl"], "Type" -> HType
- | ["hl"], "UI16" -> HUI16
- | ["hl"], "UI8" -> HUI8
- | ["hl"], "I64" -> HI64
- | ["hl"], "NativeArray" -> HArray (to_type ctx (List.hd pl))
- | ["haxe";"macro"], "Position" -> HAbstract ("macro_pos", alloc_string ctx "macro_pos")
- | _ -> failwith ("Unknown core type " ^ s_type_path a.a_path))
- else
- get_rec_cache ctx t
- (fun() -> HDyn)
- (fun tref -> to_type ~tref ctx (Abstract.get_underlying_type a pl))
- and resolve_class ctx c pl statics =
- let not_supported() =
- failwith ("Extern type not supported : " ^ s_type (print_context()) (TInst (c,pl)))
- in
- match c.cl_path, pl with
- | ([],"Array"), [t] ->
- if statics then ctx.array_impl.abase else array_class ctx (to_type ctx t)
- | ([],"Array"), [] ->
- die "" __LOC__
- | _, _ when (has_class_flag c CExtern) ->
- not_supported()
- | _ ->
- c
- and cfield_type ctx cf =
- let t = to_type ctx cf.cf_type in
- let t = (match cf.cf_kind, t with
- | Method (MethNormal|MethInline), HFun (args,ret) -> HMethod (args,ret)
- | _ -> t
- ) in
- (cf.cf_name,alloc_string ctx cf.cf_name,t)
- and field_type ctx f p =
- match f with
- | FInstance (c,pl,f) | FClosure (Some (c,pl),f) ->
- let creal = resolve_class ctx c pl false in
- let rec loop c =
- try
- PMap.find f.cf_name c.cl_fields
- with Not_found ->
- match c.cl_super with
- | Some (csup,_) -> loop csup
- | None -> abort (s_type_path creal.cl_path ^ " is missing field " ^ f.cf_name) p
- in
- (loop creal).cf_type
- | FStatic (_,f) | FAnon f | FClosure (_,f) -> f.cf_type
- | FDynamic _ -> t_dynamic
- | FEnum (_,f) -> f.ef_type
- and real_type ctx e =
- let rec loop e =
- match e.eexpr with
- | TField (_,f) ->
- let ft = field_type ctx f e.epos in
- (match ft, e.etype with
- | TFun (args,ret), TFun (args2,_) ->
- TFun (List.map2 (fun ((name,opt,t) as a) ((_,_,t2) as a2) ->
- match t, t2 with
- (*
- Handle function variance:
- If we have type parameters which are function types, we need to keep the functions
- because we might need to insert a cast to coerce Void->Bool to Void->Dynamic for instance.
- *)
- | TInst ({cl_kind=KTypeParameter _},_), TFun _ -> a2
- (*
- If we have a number, it is more accurate to cast it to the type parameter before wrapping it as dynamic
- Ignore dynamic method (#7166)
- *)
- | TInst ({cl_kind=KTypeParameter _},_), t when is_number (to_type ctx t) && (match f with FInstance (_,_,{ cf_kind = Var _ | Method MethDynamic }) -> false | _ -> true) ->
- (name, opt, TAbstract (fake_tnull,[t]))
- | _ ->
- a
- ) args args2, ret)
- | _ -> ft)
- | TLocal v -> v.v_type
- | TParenthesis e -> loop e
- | TArray (arr,_) ->
- let rec loop t =
- match follow t with
- | TInst({ cl_path = [],"Array" },[t]) -> t
- | TAbstract (a,pl) -> loop (Abstract.get_underlying_type a pl)
- | _ -> t_dynamic
- in
- loop arr.etype
- | _ -> e.etype
- in
- to_type ctx (loop e)
- and class_type ?(tref=None) ctx c pl statics =
- let c = if (has_class_flag c CExtern) then resolve_class ctx c pl statics else c in
- let key_path = (if statics then "$" ^ snd c.cl_path else snd c.cl_path) :: fst c.cl_path in
- try
- PMap.find key_path ctx.cached_types
- with Not_found when (has_class_flag c CInterface) && not statics ->
- let vp = {
- vfields = [||];
- vindex = PMap.empty;
- } in
- let t = HVirtual vp in
- ctx.cached_types <- PMap.add key_path t ctx.cached_types;
- let rec loop c =
- let rec concat_uniq fields pfields =
- match pfields with
- | (n,_,_) as pf::pfl -> if List.exists (fun (n1,_,_) -> n1 = n) fields then concat_uniq fields pfl else concat_uniq (pf::fields) pfl
- | [] -> fields
- in
- let pfields = List.fold_left (fun acc (i,_) -> loop i @ acc) [] c.cl_implements in
- let fields = PMap.fold (fun cf acc -> cfield_type ctx cf :: acc) c.cl_fields [] in
- concat_uniq fields pfields
- in
- let fields = loop c in
- let fields = List.sort (fun (n1,_,_) (n2,_,_) -> compare n1 n2) fields in
- vp.vfields <- Array.of_list fields;
- Array.iteri (fun i (n,_,_) -> vp.vindex <- PMap.add n i vp.vindex) vp.vfields;
- t
- | Not_found ->
- let pname = s_type_path (List.tl key_path, List.hd key_path) in
- let p = {
- pname = pname;
- pid = alloc_string ctx pname;
- psuper = None;
- pclassglobal = None;
- pproto = [||];
- pfields = [||];
- pindex = PMap.empty;
- pvirtuals = [||];
- pfunctions = PMap.empty;
- pnfields = -1;
- pinterfaces = PMap.empty;
- pbindings = [];
- } in
- let t = (if Meta.has Meta.Struct c.cl_meta && not statics then HStruct p else HObj p) in
- (match tref with
- | None -> ()
- | Some r -> r := Some t);
- ctx.ct_depth <- ctx.ct_depth + 1;
- ctx.cached_types <- PMap.add key_path t ctx.cached_types;
- if c.cl_path = ([],"Array") then die "" __LOC__;
- if c == ctx.base_class then begin
- if statics then die "" __LOC__;
- p.pnfields <- 1;
- end;
- let tsup = (match c.cl_super with
- | Some (csup,pl) when not statics -> Some (class_type ctx csup [] statics)
- | _ -> if statics then Some (class_type ctx ctx.base_class [] false) else None
- ) in
- let start_field, virtuals = (match tsup with
- | None -> 0, [||]
- | Some ((HObj psup | HStruct psup) as pt) ->
- 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;
- if psup.pnfields < 0 then die "" __LOC__;
- p.psuper <- Some psup;
- psup.pnfields, psup.pvirtuals
- | _ -> die "" __LOC__
- ) in
- let fa = DynArray.create() and pa = DynArray.create() and virtuals = DynArray.of_array virtuals in
- let add_field name get_t =
- let fid = DynArray.length fa + start_field in
- let str = alloc_string ctx name in
- p.pindex <- PMap.add name (fid, HVoid) p.pindex;
- DynArray.add fa (name, str, HVoid);
- ctx.ct_delayed <- (fun() ->
- let t = get_t() in
- p.pindex <- PMap.add name (fid, t) p.pindex;
- Array.set p.pfields (fid - start_field) (name, str, t);
- ) :: ctx.ct_delayed;
- fid
- in
- List.iter (fun f ->
- if is_extern_field f || (statics && f.cf_name = "__meta__") then () else
- let fid = (match f.cf_kind with
- | Method m when m <> MethDynamic && not statics ->
- let g = alloc_fid ctx c f in
- p.pfunctions <- PMap.add f.cf_name g p.pfunctions;
- let virt = if has_class_field_flag f CfOverride then
- let vid = (try -(fst (get_index f.cf_name p))-1 with Not_found -> die "" __LOC__) in
- DynArray.set virtuals vid g;
- Some vid
- else if is_overridden ctx c f then begin
- let vid = DynArray.length virtuals in
- DynArray.add virtuals g;
- p.pindex <- PMap.add f.cf_name (-vid-1,HVoid) p.pindex;
- Some vid
- end else
- None
- in
- DynArray.add pa { fname = f.cf_name; fid = alloc_string ctx f.cf_name; fmethod = g; fvirtual = virt; };
- None
- | Method MethDynamic when has_class_field_flag f CfOverride ->
- Some (try fst (get_index f.cf_name p) with Not_found -> die "" __LOC__)
- | _ ->
- let fid = add_field f.cf_name (fun() ->
- let t = to_type ctx f.cf_type in
- if has_meta (Meta.Custom ":packed") f.cf_meta then begin
- (match t with HStruct _ -> () | _ -> abort "Packed field should be struct" f.cf_pos);
- HPacked t
- end else t
- ) in
- Some fid
- ) in
- match f.cf_kind, f.cf_expr, fid with
- | Method _, Some _, Some fid -> p.pbindings <- (fid, alloc_fun_path ctx c.cl_path f.cf_name) :: p.pbindings
- | _ -> ()
- ) (if statics then c.cl_ordered_statics else c.cl_ordered_fields);
- if not statics then begin
- (* add interfaces *)
- List.iter (fun (i,pl) ->
- let rid = ref (-1) in
- rid := add_field "" (fun() ->
- let t = to_type ctx (TInst (i,pl)) in
- p.pinterfaces <- PMap.add t !rid p.pinterfaces;
- t
- );
- ) c.cl_implements;
- (* check toString *)
- (try
- let cf = PMap.find "toString" c.cl_fields in
- if has_class_field_flag cf CfOverride || PMap.mem "__string" c.cl_fields || not (is_to_string cf.cf_type) then raise Not_found;
- DynArray.add pa { fname = "__string"; fid = alloc_string ctx "__string"; fmethod = alloc_fun_path ctx c.cl_path "__string"; fvirtual = None; }
- with Not_found ->
- ());
- end else begin
- (match c.cl_constructor with
- | Some f when not (is_extern_field f) ->
- p.pbindings <- ((try fst (get_index "__constructor__" p) with Not_found -> die "" __LOC__),alloc_fid ctx c f) :: p.pbindings
- | _ -> ());
- end;
- p.pnfields <- DynArray.length fa + start_field;
- p.pfields <- DynArray.to_array fa;
- p.pproto <- DynArray.to_array pa;
- p.pvirtuals <- DynArray.to_array virtuals;
- ctx.ct_depth <- ctx.ct_depth - 1;
- if ctx.ct_depth = 0 then begin
- let todo = ctx.ct_delayed in
- ctx.ct_delayed <- [];
- List.iter (fun f -> f()) todo;
- end;
- 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)));
- t
- and enum_type ?(tref=None) ctx e =
- let key_path = snd e.e_path :: fst e.e_path in
- try
- PMap.find key_path ctx.cached_types
- with Not_found ->
- let ename = s_type_path e.e_path in
- let et = {
- eglobal = None;
- ename = ename;
- eid = alloc_string ctx ename;
- efields = [||];
- } in
- let t = HEnum et in
- (match tref with
- | None -> ()
- | Some r -> r := Some t);
- ctx.cached_types <- PMap.add key_path t ctx.cached_types;
- et.efields <- Array.of_list (List.map (fun f ->
- let f = PMap.find f e.e_constrs in
- let args = (match f.ef_type with
- | TFun (args,_) -> Array.of_list (List.map (fun (_,_,t) -> to_type ctx t) args)
- | _ -> [||]
- ) in
- (f.ef_name, alloc_string ctx f.ef_name, args)
- ) e.e_names);
- let ct = enum_class ctx e in
- et.eglobal <- Some (alloc_global ctx (match ct with HObj o -> o.pname | _ -> die "" __LOC__) ct);
- t
- and enum_class ctx e =
- let key_path = ("$" ^ snd e.e_path) :: fst e.e_path in
- try
- PMap.find key_path ctx.cached_types
- with Not_found ->
- let pname = s_type_path (List.tl key_path, List.hd key_path) in
- let p = {
- pname = pname;
- pid = alloc_string ctx pname;
- psuper = None;
- pclassglobal = None;
- pproto = [||];
- pfields = [||];
- pindex = PMap.empty;
- pvirtuals = [||];
- pfunctions = PMap.empty;
- pnfields = -1;
- pinterfaces = PMap.empty;
- pbindings = [];
- } in
- let t = HObj p in
- ctx.cached_types <- PMap.add key_path t ctx.cached_types;
- p.psuper <- Some (match class_type ctx ctx.base_enum [] false with HObj o -> o | _ -> die "" __LOC__);
- t
- and alloc_fun_path ctx path name =
- lookup ctx.cfids (name, path) (fun() -> ())
- and alloc_fid ctx c f =
- match f.cf_kind with
- | Var _ -> die "" __LOC__
- | _ -> alloc_fun_path ctx c.cl_path f.cf_name
- and alloc_eid ctx e f =
- alloc_fun_path ctx e.e_path f.ef_name
- and alloc_function_name ctx f =
- alloc_fun_path ctx ([],"") f
- and alloc_global ctx name t =
- lookup ctx.cglobals name (fun() -> t)
- and class_global ?(resolve=true) ctx c =
- let static = c != ctx.base_class in
- 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
- let c = resolve_class ctx c (extract_param_types c.cl_params) static in
- let t = class_type ctx c [] static in
- alloc_global ctx ("$" ^ s_type_path c.cl_path) t, t
- let resolve_class_global ctx cpath =
- lookup ctx.cglobals ("$" ^ cpath) (fun() -> die "" __LOC__)
- let resolve_type ctx path =
- PMap.find path ctx.cached_types
- let alloc_std ctx name args ret =
- let lib = "std" in
- (* different from :hlNative to prevent mismatch *)
- let nid = lookup ctx.cnatives ("$" ^ name ^ "@" ^ lib, -1) (fun() ->
- let fid = alloc_fun_path ctx ([],"std") name in
- Hashtbl.add ctx.defined_funs fid ();
- (alloc_string ctx lib, alloc_string ctx name,HFun (args,ret),fid)
- ) in
- let _,_,_,fid = DynArray.get ctx.cnatives.arr nid in
- fid
- let alloc_fresh ctx t =
- let rid = DynArray.length ctx.m.mregs.arr in
- DynArray.add ctx.m.mregs.arr t;
- rid
- let alloc_tmp ctx t =
- if not ctx.optimize then alloc_fresh ctx t else
- let a = try PMap.find t ctx.m.mallocs with Not_found ->
- let a = {
- a_all = [];
- a_hold = [];
- } in
- ctx.m.mallocs <- PMap.add t a ctx.m.mallocs;
- a
- in
- match a.a_all with
- | [] ->
- let r = alloc_fresh ctx t in
- a.a_all <- [r];
- r
- | r :: _ ->
- r
- let current_pos ctx =
- DynArray.length ctx.m.mops
- let rtype ctx r =
- DynArray.get ctx.m.mregs.arr r
- let hold ctx r =
- if not ctx.optimize then () else
- let t = rtype ctx r in
- let a = PMap.find t ctx.m.mallocs in
- let rec loop l =
- match l with
- | [] -> if List.mem r a.a_hold then [] else die "" __LOC__
- | n :: l when n = r -> l
- | n :: l -> n :: loop l
- in
- a.a_all <- loop a.a_all;
- a.a_hold <- r :: a.a_hold
- let free ctx r =
- if not ctx.optimize then () else
- let t = rtype ctx r in
- let a = PMap.find t ctx.m.mallocs in
- let last = ref true in
- let rec loop l =
- match l with
- | [] -> die "" __LOC__
- | n :: l when n = r ->
- if List.mem r l then last := false;
- l
- | n :: l -> n :: loop l
- in
- a.a_hold <- loop a.a_hold;
- (* insert sorted *)
- let rec loop l =
- match l with
- | [] -> [r]
- | n :: _ when n > r -> r :: l
- | n :: l -> n :: loop l
- in
- if !last then a.a_all <- loop a.a_all
- let decl_var ctx v =
- ctx.m.mdeclared <- v.v_id :: ctx.m.mdeclared
- let alloc_var ctx v new_var =
- if new_var then decl_var ctx v;
- try
- Hashtbl.find ctx.m.mvars v.v_id
- with Not_found ->
- let r = alloc_tmp ctx (to_type ctx v.v_type) in
- hold ctx r;
- Hashtbl.add ctx.m.mvars v.v_id r;
- r
- let push_op ctx o =
- DynArray.add ctx.m.mdebug ctx.m.mcurpos;
- DynArray.add ctx.m.mops o
- let op ctx o =
- match o with
- | OMov (a,b) when a = b ->
- ()
- | _ ->
- push_op ctx o
- let set_op ctx pos o =
- DynArray.set ctx.m.mops pos o
- let alloc_array ctx size et =
- let a = alloc_tmp ctx (HArray HDyn) in
- let b = alloc_tmp ctx (HArray et) in
- let rt = alloc_tmp ctx HType in
- op ctx (OType (rt,et));
- op ctx (OCall2 (a,alloc_std ctx "alloc_array" [HType;HI32] (HArray HDyn),rt,size));
- op ctx (OUnsafeCast(b,a));
- b
- let jump ctx f =
- let pos = current_pos ctx in
- op ctx (OJAlways (-1)); (* loop *)
- (fun() -> set_op ctx pos (f (current_pos ctx - pos - 1)))
- let jump_back ctx =
- let pos = current_pos ctx in
- op ctx (OLabel 0);
- (fun() -> op ctx (OJAlways (pos - current_pos ctx - 1)))
- let reg_int ctx v =
- let r = alloc_tmp ctx HI32 in
- op ctx (OInt (r,alloc_i32 ctx (Int32.of_int v)));
- r
- let shl ctx idx v =
- if v = 0 then
- idx
- else begin
- hold ctx idx;
- let rv = reg_int ctx v in
- let idx2 = alloc_tmp ctx HI32 in
- op ctx (OShl (idx2, idx, rv));
- free ctx idx;
- idx2;
- end
- let set_default ctx r =
- match rtype ctx r with
- | HUI8 | HUI16 | HI32 | HI64 ->
- op ctx (OInt (r,alloc_i32 ctx 0l))
- | HF32 | HF64 ->
- op ctx (OFloat (r,alloc_float ctx 0.))
- | HBool ->
- op ctx (OBool (r, false))
- | HType ->
- op ctx (OType (r, HVoid))
- | _ ->
- op ctx (ONull r)
- let read_mem ctx rdst bytes index t =
- match t with
- | HUI8 ->
- op ctx (OGetUI8 (rdst,bytes,index))
- | HUI16 ->
- op ctx (OGetUI16 (rdst,bytes,index))
- | HI32 | HI64 | HF32 | HF64 ->
- op ctx (OGetMem (rdst,bytes,index))
- | _ ->
- die "" __LOC__
- let write_mem ctx bytes index t r =
- match t with
- | HUI8 ->
- op ctx (OSetUI8 (bytes,index,r))
- | HUI16 ->
- op ctx (OSetUI16 (bytes,index,r))
- | HI32 | HI64 | HF32 | HF64 ->
- op ctx (OSetMem (bytes,index,r))
- | _ ->
- die "" __LOC__
- let common_type_number ctx t1 t2 p =
- if t1 == t2 then t1 else
- match t1, t2 with
- | HUI8, (HUI16 | HI32 | HI64 | HF32 | HF64) -> t2
- | HUI16, (HI32 | HI64 | HF32 | HF64) -> t2
- | (HI32 | HI64), HF32 -> t2 (* possible loss of precision *)
- | (HI32 | HI64 | HF32), HF64 -> t2
- | (HUI8|HUI16|HI32|HI64|HF32|HF64), (HUI8|HUI16|HI32|HI64|HF32|HF64) -> t1
- | _ ->
- die "" __LOC__
- let common_type ctx e1 e2 for_eq p =
- let t1 = to_type ctx e1.etype in
- let t2 = to_type ctx e2.etype in
- if t1 == t2 then t1 else
- match t1, t2 with
- | (HUI8|HUI16|HI32|HI64|HF32|HF64), (HUI8|HUI16|HI32|HI64|HF32|HF64) -> common_type_number ctx t1 t2 p
- | (HUI8|HUI16|HI32|HI64|HF32|HF64 as t1), (HNull t2)
- | (HNull t1), (HUI8|HUI16|HI32|HI64|HF32|HF64 as t2)
- | (HNull t1), (HNull t2)
- -> if for_eq then HNull (common_type_number ctx t1 t2 p) else common_type_number ctx t1 t2 p
- | HDyn, (HUI8|HUI16|HI32|HI64|HF32|HF64) -> HF64
- | (HUI8|HUI16|HI32|HI64|HF32|HF64), HDyn -> HF64
- | HDyn, _ -> HDyn
- | _, HDyn -> HDyn
- | _ when for_eq && safe_cast t1 t2 -> t2
- | _ when for_eq && safe_cast t2 t1 -> t1
- | HBool, HNull HBool when for_eq -> t2
- | HNull HBool, HBool when for_eq -> t1
- | HObj _, HVirtual _ | HVirtual _, HObj _ | HVirtual _ , HVirtual _ -> HDyn
- | HFun _, HFun _ -> HDyn
- | _ ->
- abort ("Can't find common type " ^ tstr t1 ^ " and " ^ tstr t2) p
- let captured_index ctx v =
- 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
- let real_name v =
- let rec loop = function
- | [] -> v.v_name
- | (Meta.RealPath,[EConst (String(name,_)),_],_) :: _ -> name
- | _ :: l -> loop l
- in
- match loop v.v_meta with
- | "_gthis" -> "this"
- | name -> match v.v_kind with
- | VInlinedConstructorVariable sl -> String.concat "." sl
- | _ -> name
- let not_debug_var ctx v = match v.v_kind with
- | VUser _ -> false
- | VInlinedConstructorVariable _ -> false
- | _ -> true
- let add_assign ?(force=false) ctx v =
- if not force && not_debug_var ctx v then () else
- let name = real_name v in
- ctx.m.massign <- (alloc_string ctx name, current_pos ctx - 1) :: ctx.m.massign
- let add_capture ctx r =
- Array.iter (fun v ->
- let name = real_name v in
- ctx.m.massign <- (alloc_string ctx name, -(r+2)) :: ctx.m.massign
- ) ctx.m.mcaptured.c_vars
- let before_return ctx =
- let rec loop i =
- if i > 0 then begin
- op ctx (OEndTrap false);
- loop (i - 1)
- end
- in
- loop ctx.m.mtrys
- let before_break_continue ctx =
- let rec loop i =
- if i > 0 then begin
- op ctx (OEndTrap false);
- loop (i - 1)
- end
- in
- loop (ctx.m.mtrys - ctx.m.mloop_trys)
- let type_value ctx t p =
- match t with
- | TClassDecl c ->
- let g, t = class_global ctx c in
- let r = alloc_tmp ctx t in
- op ctx (OGetGlobal (r, g));
- r
- | TAbstractDecl a ->
- let r = alloc_tmp ctx (class_type ctx ctx.base_type [] false) in
- (match a.a_path with
- | [], "Int" -> op ctx (OGetGlobal (r, alloc_global ctx "$Int" (rtype ctx r)))
- | [], "Float" -> op ctx (OGetGlobal (r, alloc_global ctx "$Float" (rtype ctx r)))
- | [], "Bool" -> op ctx (OGetGlobal (r, alloc_global ctx "$Bool" (rtype ctx r)))
- | [], "Class" -> op ctx (OGetGlobal (r, fst (class_global ctx ctx.base_class)))
- | [], "Enum" -> op ctx (OGetGlobal (r, fst (class_global ctx ctx.base_enum)))
- | [], "Dynamic" -> op ctx (OGetGlobal (r, alloc_global ctx "$Dynamic" (rtype ctx r)))
- | _ -> abort ("Unsupported type value " ^ s_type_path (t_path t)) p);
- r
- | TEnumDecl e ->
- let r = alloc_tmp ctx (enum_class ctx e) in
- let rt = rtype ctx r in
- op ctx (OGetGlobal (r, alloc_global ctx (match rt with HObj o -> o.pname | _ -> die "" __LOC__) rt));
- r
- | TTypeDecl _ ->
- die "" __LOC__
- let rec eval_to ctx e (t:ttype) =
- match e.eexpr, t with
- | TConst (TInt i), HF64 ->
- let r = alloc_tmp ctx t in
- op ctx (OFloat (r,alloc_float ctx (Int32.to_float i)));
- r
- (* this causes a bug with NG, to be reviewed later
- | TConst (TInt i), HF32 ->
- let r = alloc_tmp ctx t in
- let bits = Int32.bits_of_float (Int32.to_float i) in
- op ctx (OFloat (r,alloc_float ctx (Int64.float_of_bits (Int64.of_int32 bits))));
- r
- | TConst (TFloat f), HF32 ->
- let r = alloc_tmp ctx t in
- let bits = Int32.bits_of_float (float_of_string f) in
- op ctx (OFloat (r,alloc_float ctx (Int64.float_of_bits (Int64.of_int32 bits))));
- r
- *)
- | _ ->
- let r = eval_expr ctx e in
- cast_to ctx r t e.epos
- and to_string ctx (r:reg) p =
- let rt = rtype ctx r in
- if safe_cast rt ctx.tstring then r else
- match rt with
- | HUI8 | HUI16 | HI32 ->
- let len = alloc_tmp ctx HI32 in
- hold ctx len;
- let lref = alloc_tmp ctx (HRef HI32) in
- let bytes = alloc_tmp ctx HBytes in
- op ctx (ORef (lref,len));
- op ctx (OCall2 (bytes,alloc_std ctx "itos" [HI32;HRef HI32] HBytes,cast_to ctx r HI32 p,lref));
- let out = alloc_tmp ctx ctx.tstring in
- op ctx (OCall2 (out,alloc_fun_path ctx ([],"String") "__alloc__",bytes,len));
- free ctx len;
- out
- | HF32 | HF64 ->
- let len = alloc_tmp ctx HI32 in
- let lref = alloc_tmp ctx (HRef HI32) in
- let bytes = alloc_tmp ctx HBytes in
- op ctx (ORef (lref,len));
- op ctx (OCall2 (bytes,alloc_std ctx "ftos" [HF64;HRef HI32] HBytes,cast_to ctx r HF64 p,lref));
- let out = alloc_tmp ctx ctx.tstring in
- op ctx (OCall2 (out,alloc_fun_path ctx ([],"String") "__alloc__",bytes,len));
- out
- | _ ->
- let r = cast_to ctx r HDyn p in
- let out = alloc_tmp ctx ctx.tstring in
- op ctx (OJNotNull (r,2));
- op ctx (ONull out);
- op ctx (OJAlways 1);
- op ctx (OCall1 (out,alloc_fun_path ctx ([],"Std") "string",r));
- out
- and cast_to ?(force=false) ctx (r:reg) (t:ttype) p =
- let rt = rtype ctx r in
- if safe_cast rt t then r else
- match rt, t with
- | _, HVoid ->
- alloc_tmp ctx HVoid
- | HVirtual _, HVirtual _ ->
- let tmp = alloc_tmp ctx HDyn in
- op ctx (OMov (tmp,r));
- cast_to ctx tmp t p
- | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64), (HF32 | HF64) ->
- let tmp = alloc_tmp ctx t in
- op ctx (OToSFloat (tmp, r));
- tmp
- | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64), (HUI8 | HUI16 | HI32 | HI64) ->
- let tmp = alloc_tmp ctx t in
- op ctx (OToInt (tmp, r));
- tmp
- | HObj o, HVirtual _ ->
- let out = alloc_tmp ctx t in
- (try
- let rec lookup_intf o =
- try
- PMap.find t o.pinterfaces
- with Not_found ->
- match o.psuper with
- | None -> raise Not_found
- | Some o -> lookup_intf o
- in
- let fid = lookup_intf o in
- (* memoisation *)
- let need_null_check r =
- not (r = 0 && ctx.m.mhasthis)
- in
- let jend = if need_null_check r then
- let jnull = jump ctx (fun d -> OJNotNull (r,d)) in
- op ctx (ONull out);
- let jend = jump ctx (fun d -> OJAlways d) in
- jnull();
- jend
- else
- (fun() -> ())
- in
- op ctx (OField (out, r, fid));
- let j = jump ctx (fun d -> OJNotNull (out,d)) in
- op ctx (OToVirtual (out,r));
- op ctx (OSetField (r, fid, out));
- jend();
- j();
- with Not_found ->
- (* not an interface *)
- op ctx (OToVirtual (out,r)));
- out
- | (HDynObj | HDyn) , HVirtual _ ->
- let out = alloc_tmp ctx t in
- op ctx (OToVirtual (out,r));
- out
- | HDyn, _ ->
- let out = alloc_tmp ctx t in
- op ctx (OSafeCast (out, r));
- out
- | HNull rt, _ when t = rt ->
- let out = alloc_tmp ctx t in
- op ctx (OSafeCast (out, r));
- out
- | HVoid, HDyn ->
- let tmp = alloc_tmp ctx HDyn in
- op ctx (ONull tmp);
- tmp
- | _ , HDyn ->
- let tmp = alloc_tmp ctx HDyn in
- op ctx (OToDyn (tmp, r));
- tmp
- | _, HNull t when rt == t ->
- let tmp = alloc_tmp ctx (HNull t) in
- op ctx (OToDyn (tmp, r));
- tmp
- | HNull t1, HNull t2 ->
- let j = jump ctx (fun n -> OJNull (r,n)) in
- let rtmp = alloc_tmp ctx t1 in
- op ctx (OSafeCast (rtmp,r));
- let out = cast_to ctx rtmp t p in
- op ctx (OJAlways 1);
- j();
- op ctx (ONull out);
- out
- | HRef t1, HNull t2 ->
- let j = jump ctx (fun n -> OJNull (r,n)) in
- let rtmp = alloc_tmp ctx t1 in
- op ctx (OUnref (rtmp,r));
- let out = cast_to ctx rtmp t p in
- op ctx (OJAlways 1);
- j();
- op ctx (ONull out);
- out
- | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64), HNull ((HF32 | HF64) as t) ->
- let tmp = alloc_tmp ctx t in
- op ctx (OToSFloat (tmp, r));
- let r = alloc_tmp ctx (HNull t) in
- op ctx (OToDyn (r,tmp));
- r
- | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64), HNull ((HUI8 | HUI16 | HI32) as t) ->
- let tmp = alloc_tmp ctx t in
- op ctx (OToInt (tmp, r));
- let r = alloc_tmp ctx (HNull t) in
- op ctx (OToDyn (r,tmp));
- r
- | HNull ((HUI8 | HUI16 | HI32 | HI64) as it), (HF32 | HF64) ->
- let i = alloc_tmp ctx it in
- op ctx (OSafeCast (i,r));
- let tmp = alloc_tmp ctx t in
- op ctx (OToSFloat (tmp, i));
- tmp
- | HNull ((HF32 | HF64) as it), (HUI8 | HUI16 | HI32 | HI64) ->
- let i = alloc_tmp ctx it in
- op ctx (OSafeCast (i,r));
- let tmp = alloc_tmp ctx t in
- op ctx (OToInt (tmp, i));
- tmp
- | HFun (args1,ret1), HFun (args2, ret2) when List.length args1 = List.length args2 ->
- let fid = gen_method_wrapper ctx rt t p in
- let fr = alloc_tmp ctx t in
- op ctx (OJNotNull (r,2));
- op ctx (ONull fr);
- op ctx (OJAlways 1);
- op ctx (OInstanceClosure (fr,fid,r));
- fr
- | HObj _, HObj _ when is_array_type rt && is_array_type t ->
- let out = alloc_tmp ctx t in
- op ctx (OSafeCast (out, r));
- out
- | HNull _, HRef t2 ->
- let out = alloc_tmp ctx t in
- op ctx (OJNotNull (r,2));
- op ctx (ONull out);
- let j = jump ctx (fun n -> OJAlways n) in
- let r = cast_to ctx r t2 p in
- let r2 = alloc_tmp ctx t2 in
- op ctx (OMov (r2, r));
- hold ctx r2; (* retain *)
- op ctx (ORef (out,r2));
- j();
- out
- | _, HRef t2 ->
- let r = cast_to ctx r t2 p in
- let r2 = alloc_tmp ctx t2 in
- op ctx (OMov (r2, r));
- hold ctx r2; (* retain *)
- let out = alloc_tmp ctx t in
- op ctx (ORef (out,r2));
- out
- | _ ->
- if force then
- let out = alloc_tmp ctx t in
- op ctx (OSafeCast (out, r));
- out
- else
- abort ("Don't know how to cast " ^ tstr rt ^ " to " ^ tstr t) p
- and unsafe_cast_to ?(debugchk=true) ctx (r:reg) (t:ttype) p =
- let rt = rtype ctx r in
- if safe_cast rt t then
- r
- else
- match rt with
- | HFun _ ->
- cast_to ctx r t p
- | HDyn when is_array_type t ->
- cast_to ctx r t p
- | (HDyn | HObj _) when (match t with HVirtual _ -> true | _ -> false) ->
- cast_to ctx r t p
- | HObj _ when is_array_type rt && is_array_type t ->
- cast_to ctx r t p
- | HVirtual _ when (match t with HObj _ | HVirtual _ -> true | _ -> false) ->
- cast_to ~force:true ctx r t p
- | _ ->
- if is_dynamic (rtype ctx r) && is_dynamic t then
- let r2 = alloc_tmp ctx t in
- op ctx (OUnsafeCast (r2,r));
- if ctx.com.debug && debugchk then begin
- hold ctx r2;
- let r3 = cast_to ~force:true ctx r t p in
- let j = jump ctx (fun n -> OJEq (r2,r3,n)) in
- op ctx (OAssert 0);
- j();
- free ctx r2;
- end;
- r2
- else
- cast_to ~force:true ctx r t p
- and object_access ctx eobj t f =
- match t with
- | HObj p | HStruct p ->
- (try
- let fid = fst (get_index f.cf_name p) in
- if f.cf_kind = Method MethNormal then
- AInstanceProto (eobj, -fid-1)
- else
- AInstanceField (eobj, fid)
- with Not_found ->
- ADynamic (eobj, alloc_string ctx f.cf_name))
- | HVirtual v ->
- (try
- let fid = PMap.find f.cf_name v.vindex in
- if f.cf_kind = Method MethNormal then
- AVirtualMethod (eobj, fid)
- else
- AInstanceField (eobj, fid)
- with Not_found ->
- ADynamic (eobj, alloc_string ctx f.cf_name))
- | HDyn ->
- ADynamic (eobj, alloc_string ctx f.cf_name)
- | _ ->
- abort ("Unsupported field access " ^ tstr t) eobj.epos
- and direct_method_call ctx c f ethis =
- if (match f.cf_kind with Method m -> m = MethDynamic | Var _ -> true) then
- false
- else if (has_class_flag c CInterface) then
- false
- else if (match c.cl_kind with KTypeParameter _ -> true | _ -> false) then
- false
- else if is_overridden ctx c f && ethis.eexpr <> TConst(TSuper) then
- false
- else
- true
- and get_access ctx e =
- match e.eexpr with
- | TField (ethis, a) ->
- (match a, follow ethis.etype with
- | FStatic (c,({ cf_kind = Var _ | Method MethDynamic } as f)), _ ->
- let g, t = class_global ctx c in
- 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__))
- | FStatic (c,({ cf_kind = Method _ } as f)), _ ->
- AStaticFun (alloc_fid ctx c f)
- | FClosure (Some (cdef,pl), f), TInst (c,_)
- | FInstance (cdef,pl,f), TInst (c,_) when direct_method_call ctx c f ethis ->
- (* cdef is the original definition, we want the last redefinition *)
- let rec loop c =
- if PMap.mem f.cf_name c.cl_fields then c else (match c.cl_super with None -> cdef | Some (c,_) -> loop c)
- in
- let last_def = loop c in
- AInstanceFun (ethis, alloc_fid ctx (resolve_class ctx last_def pl false) f)
- | (FInstance (cdef,pl,f) | FClosure (Some (cdef,pl), f)), _ ->
- let rec loop t =
- match follow t with
- | TInst (c,pl) -> c, pl
- | TAbstract (a,pl) -> loop (Abstract.get_underlying_type a pl)
- | _ -> abort (s_type (print_context()) ethis.etype ^ " hl type should be interface") ethis.epos
- in
- let cdef, pl = if (has_class_flag cdef CInterface) then loop ethis.etype else cdef,pl in
- object_access ctx ethis (class_type ctx cdef pl false) f
- | (FAnon f | FClosure(None,f)), _ ->
- object_access ctx ethis (to_type ctx ethis.etype) f
- | FDynamic name, _ ->
- ADynamic (ethis, alloc_string ctx name)
- | FEnum (e,ef), _ ->
- (match follow ef.ef_type with
- | TFun _ -> AEnum (e,ef.ef_index)
- | t -> AGlobal (alloc_global ctx (efield_name e ef) (to_type ctx t))))
- | TLocal v ->
- (match captured_index ctx v with
- | None -> ALocal (v, alloc_var ctx v false)
- | Some idx -> ACaptured idx)
- | TParenthesis e ->
- get_access ctx e
- | TArray (a,i) ->
- let rec loop t =
- match follow t with
- | TInst({ cl_path = [],"Array" },[t]) ->
- let a = eval_null_check ctx a in
- hold ctx a;
- let i = eval_to ctx i HI32 in
- free ctx a;
- let t = to_type ctx t in
- AArray (a,(t,t),i)
- | TInst ({ cl_path = ["hl"],"Abstract" },[TInst({ cl_kind = KExpr (EConst (String("hl_carray",_)),_) },_)]) ->
- let a = eval_expr ctx a in
- hold ctx a;
- let i = eval_to ctx i HI32 in
- free ctx a;
- let t = to_type ctx e.etype in
- ACArray (a,t,i)
- | TAbstract (a,pl) ->
- loop (Abstract.get_underlying_type a pl)
- | _ ->
- let a = eval_to ctx a (class_type ctx ctx.array_impl.adyn [] false) in
- op ctx (ONullCheck a);
- hold ctx a;
- let i = eval_to ctx i HI32 in
- free ctx a;
- AArray (a,(HDyn,to_type ctx e.etype),i)
- in
- loop a.etype
- | _ ->
- ANone
- and array_read ctx ra (at,vt) ridx p =
- match at with
- | HUI8 | HUI16 | HI32 | HF32 | HF64 | HI64 ->
- (* check bounds *)
- hold ctx ridx;
- let length = alloc_tmp ctx HI32 in
- free ctx ridx;
- op ctx (OField (length, ra, 0));
- let j = jump ctx (fun i -> OJULt (ridx,length,i)) in
- let r = alloc_tmp ctx (match at with HUI8 | HUI16 -> HI32 | _ -> at) in
- (match at with
- | HUI8 | HUI16 | HI32 | HI64 ->
- op ctx (OInt (r,alloc_i32 ctx 0l));
- | HF32 | HF64 ->
- op ctx (OFloat (r,alloc_float ctx 0.));
- | _ ->
- die "" __LOC__);
- let jend = jump ctx (fun i -> OJAlways i) in
- j();
- let hbytes = alloc_tmp ctx HBytes in
- op ctx (OField (hbytes, ra, 1));
- read_mem ctx r hbytes (shl ctx ridx (type_size_bits at)) at;
- jend();
- cast_to ctx r vt p
- | HDyn ->
- (* call getDyn *)
- let r = alloc_tmp ctx HDyn in
- op ctx (OCallMethod (r,0,[ra;ridx]));
- unsafe_cast_to ctx r vt p
- | _ ->
- (* check bounds *)
- hold ctx ridx;
- let length = alloc_tmp ctx HI32 in
- free ctx ridx;
- op ctx (OField (length,ra,0));
- let j = jump ctx (fun i -> OJULt (ridx,length,i)) in
- let r = alloc_tmp ctx vt in
- set_default ctx r;
- let jend = jump ctx (fun i -> OJAlways i) in
- j();
- let tmp = alloc_tmp ctx HDyn in
- let harr = alloc_tmp ctx (HArray vt) in
- op ctx (OField (harr,ra,1));
- op ctx (OGetArray (tmp,harr,ridx));
- op ctx (OMov (r,unsafe_cast_to ctx tmp vt p));
- jend();
- r
- and jump_expr ctx e jcond =
- match e.eexpr with
- | TParenthesis e ->
- jump_expr ctx e jcond
- | TUnop (Not,_,e) ->
- jump_expr ctx e (not jcond)
- | TBinop ((OpEq | OpGte | OpLte),{ eexpr = TConst(TNull) },e) | TBinop ((OpEq | OpGte | OpLte),e,{ eexpr = TConst(TNull) }) ->
- let r = eval_expr ctx e in
- if is_nullable(rtype ctx r) then
- jump ctx (fun i -> if jcond then OJNull (r,i) else OJNotNull (r,i))
- else if not jcond then
- jump ctx (fun i -> OJAlways i)
- else
- (fun i -> ())
- | TBinop (OpNotEq,{ eexpr = TConst(TNull) },e) | TBinop (OpNotEq,e,{ eexpr = TConst(TNull) }) ->
- let r = eval_expr ctx e in
- if is_nullable(rtype ctx r) then
- jump ctx (fun i -> if jcond then OJNotNull (r,i) else OJNull (r,i))
- else if jcond then
- jump ctx (fun i -> OJAlways i)
- else
- (fun i -> ())
- | TBinop (OpEq | OpNotEq as jop, e1, e2) ->
- let jumpeq r1 r2 = jump ctx (fun i ->
- match jop with
- | OpEq -> if jcond then OJEq (r1,r2,i) else OJNotEq (r1,r2,i)
- | OpNotEq -> if jcond then OJNotEq (r1,r2,i) else OJEq (r1,r2,i)
- | _ -> die "" __LOC__
- ) in
- let nullisfalse = match jop with
- | OpEq -> jcond
- | OpNotEq -> not jcond
- | _ -> die "" __LOC__
- in
- let t1 = to_type ctx e1.etype in
- let t2 = to_type ctx e2.etype in
- (match t1, t2 with
- | HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
- | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
- | HNull (HBool as ti1), (HBool as ti2)
- | (HBool as ti1), HNull (HBool as ti2)
- ->
- let t1,t2,e1,e2 = if is_nullt t2 then t2,t1,e2,e1 else t1,t2,e1,e2 in
- let r1 = eval_expr ctx e1 in
- hold ctx r1;
- let jnull = if is_nullt t1 then jump ctx (fun i -> OJNull (r1, i)) else (fun i -> ()) in
- let t = common_type_number ctx ti1 ti2 e.epos in (* HBool has t==ti1==ti2 *)
- let a = cast_to ctx r1 t e1.epos in
- hold ctx a;
- let b = eval_to ctx e2 t in
- free ctx a;
- free ctx r1;
- let j = jumpeq a b in
- if nullisfalse then (jnull(););
- (fun() -> if not nullisfalse then (jnull();); j());
- | _ ->
- let t = common_type ctx e1 e2 true e.epos in
- let a = eval_to ctx e1 t in
- hold ctx a;
- let b = eval_to ctx e2 t in
- free ctx a;
- let j = jumpeq a b in
- (fun() -> j());
- )
- | TBinop (OpGt | OpGte | OpLt | OpLte as jop, e1, e2) ->
- let t1 = to_type ctx e1.etype in
- let t2 = to_type ctx e2.etype in
- let unsigned = unsigned_op e1 e2 in
- let jumpcmp t r1 r2 = jump ctx (fun i ->
- 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
- 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
- match jop with
- | OpGt -> if jcond then lt r2 r1 else gte r2 r1
- | OpGte -> if jcond then gte r1 r2 else lt r1 r2
- | OpLt -> if jcond then lt r1 r2 else gte r1 r2
- | OpLte -> if jcond then gte r2 r1 else lt r2 r1
- | _ -> die "" __LOC__
- ) in
- (match t1, t2 with
- | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
- | HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
- | (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
- | HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti1), HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as ti2)
- ->
- if ctx.w_null_compare && (is_nullt t1 || is_nullt t2) then
- ctx.com.warning WGenerator [] (Printf.sprintf "Null compare: %s %s %s" (tstr t1) (s_binop jop) (tstr t2)) e.epos;
- let r1 = eval_expr ctx e1 in
- hold ctx r1;
- let jnull1 = if is_nullt t1 then jump ctx (fun i -> OJNull (r1, i)) else (fun i -> ()) in
- let r2 = eval_expr ctx e2 in
- hold ctx r2;
- let jnull2 = if is_nullt t2 then jump ctx (fun i -> OJNull (r2, i)) else (fun i -> ()) in
- let t = common_type_number ctx ti1 ti2 e.epos in
- let a = cast_to ctx r1 t e1.epos in
- hold ctx a;
- let b = cast_to ctx r2 t e2.epos in
- free ctx a;
- free ctx r1;
- free ctx r2;
- let j = jumpcmp t a b in
- if jcond then (jnull1(); jnull2(););
- (fun() -> if not jcond then (jnull1(); jnull2();); j());
- | HObj { pname = "String" }, HObj { pname = "String" }
- | HDyn, _
- | _, HDyn
- ->
- let t = common_type ctx e1 e2 false e.epos in
- let a = eval_to ctx e1 t in
- hold ctx a;
- let b = eval_to ctx e2 t in
- free ctx a;
- let j = jumpcmp t a b in
- (fun() -> j());
- | _ ->
- abort ("Don't know how to compare " ^ tstr t1 ^ " and " ^ tstr t2) e.epos
- )
- | TBinop (OpBoolAnd, e1, e2) ->
- let j = jump_expr ctx e1 false in
- let j2 = jump_expr ctx e2 jcond in
- if jcond then j();
- (fun() -> if not jcond then j(); j2());
- | TBinop (OpBoolOr, e1, e2) ->
- let j = jump_expr ctx e1 true in
- let j2 = jump_expr ctx e2 jcond in
- if not jcond then j();
- (fun() -> if jcond then j(); j2());
- | _ ->
- let r = eval_to ctx e HBool in
- jump ctx (fun i -> if jcond then OJTrue (r,i) else OJFalse (r,i))
- and eval_args ctx el t p =
- let rl = List.map2 (fun e t ->
- let r = (match e.eexpr, t with
- | TConst TNull, HRef _ ->
- let r = alloc_tmp ctx t in
- op ctx (ONull r);
- r
- | _ ->
- eval_to ctx e t
- ) in
- hold ctx r;
- r
- ) el (match t with HFun (args,_) -> args | HDyn -> List.map (fun _ -> HDyn) el | _ -> die "" __LOC__) in
- List.iter (free ctx) rl;
- set_curpos ctx p;
- rl
- and eval_null_check ctx e =
- let r = eval_expr ctx e in
- (match e.eexpr with
- | TConst TThis | TConst TSuper -> ()
- | _ -> op ctx (ONullCheck r));
- r
- and make_const ctx c p =
- let cidx = lookup ctx.cconstants c (fun() ->
- let fields, t = (match c with
- | CString s ->
- let str, len = to_utf8 s p in
- [alloc_string ctx str; alloc_i32 ctx (Int32.of_int len)], ctx.tstring
- ) in
- let g = lookup_alloc ctx.cglobals t in
- g, Array.of_list fields
- ) in
- let g, _ = DynArray.get ctx.cconstants.arr cidx in
- g
- and make_string ctx s p =
- let r = alloc_tmp ctx ctx.tstring in
- op ctx (OGetGlobal (r, make_const ctx (CString s) p));
- r
- and get_enum_index ctx v =
- let r = alloc_tmp ctx HI32 in
- let re = eval_expr ctx v in
- op ctx (ONullCheck re);
- op ctx (OEnumIndex (r,re));
- r
- and eval_var ctx v =
- match captured_index ctx v with
- | None -> alloc_var ctx v false
- | Some idx ->
- let r = alloc_tmp ctx (to_type ctx v.v_type) in
- op ctx (OEnumField (r,ctx.m.mcaptreg,0,idx));
- r
- and eval_expr ctx e =
- set_curpos ctx e.epos;
- match e.eexpr with
- | TConst c ->
- (match c with
- | TInt i ->
- let r = alloc_tmp ctx HI32 in
- op ctx (OInt (r,alloc_i32 ctx i));
- r
- | TFloat f ->
- let r = alloc_tmp ctx HF64 in
- op ctx (OFloat (r,alloc_float ctx (float_of_string f)));
- r
- | TBool b ->
- let r = alloc_tmp ctx HBool in
- op ctx (OBool (r,b));
- r
- | TString s ->
- make_string ctx s e.epos
- | TThis | TSuper ->
- 0 (* first reg *)
- | TNull ->
- let r = alloc_tmp ctx (to_type ctx e.etype) in
- op ctx (ONull r);
- r)
- | TVar (v,e) ->
- (match e with
- | None ->
- if captured_index ctx v = None then decl_var ctx v
- | Some e ->
- let ri = eval_to ctx e (to_type ctx v.v_type) in
- match captured_index ctx v with
- | None ->
- let r = alloc_var ctx v true in
- push_op ctx (OMov (r,ri));
- add_assign ctx v;
- | Some idx ->
- op ctx (OSetEnumField (ctx.m.mcaptreg, idx, ri));
- );
- alloc_tmp ctx HVoid
- | TLocal v ->
- cast_to ctx (match captured_index ctx v with
- | None ->
- (* we need to make a copy for cases such as (a - a++) *)
- let r = alloc_var ctx v false in
- let r2 = alloc_tmp ctx (rtype ctx r) in
- op ctx (OMov (r2, r));
- r2
- | Some idx ->
- let r = alloc_tmp ctx (to_type ctx v.v_type) in
- op ctx (OEnumField (r, ctx.m.mcaptreg, 0, idx));
- r) (to_type ctx e.etype) e.epos
- | TReturn None ->
- before_return ctx;
- let r = alloc_tmp ctx HVoid in
- op ctx (ORet r);
- alloc_tmp ctx HDyn
- | TReturn (Some e) ->
- let r = eval_to ctx e ctx.m.mret in
- before_return ctx;
- op ctx (ORet r);
- alloc_tmp ctx HDyn
- | TParenthesis e ->
- eval_expr ctx e
- | TBlock el ->
- let rec loop = function
- | [e] -> eval_expr ctx e
- | [] -> alloc_tmp ctx HVoid
- | e :: l ->
- ignore(eval_expr ctx e);
- loop l
- in
- let old = ctx.m.mdeclared in
- ctx.m.mdeclared <- [];
- let r = loop el in
- List.iter (fun vid ->
- let r = try Hashtbl.find ctx.m.mvars vid with Not_found -> -1 in
- if r >= 0 then begin
- Hashtbl.remove ctx.m.mvars vid;
- free ctx r;
- end
- ) ctx.m.mdeclared;
- ctx.m.mdeclared <- old;
- r
- | TCall ({ eexpr = TConst TSuper } as s, el) ->
- (match follow s.etype with
- | TInst (csup,_) ->
- (match csup.cl_constructor with
- | None -> die "" __LOC__
- | Some f ->
- let r = alloc_tmp ctx HVoid in
- let el = eval_args ctx el (to_type ctx f.cf_type) e.epos in
- op ctx (OCallN (r, alloc_fid ctx csup f, 0 :: el));
- r
- )
- | _ -> die "" __LOC__);
- | TCall ({ eexpr = TIdent s }, el) when s.[0] = '$' ->
- let invalid() = abort "Invalid native call" e.epos in
- (match s, el with
- | "$new", [{ eexpr = TTypeExpr (TClassDecl _) }] ->
- (match follow e.etype with
- | TInst (c,pl) ->
- let r = alloc_tmp ctx (class_type ctx c pl false) in
- op ctx (ONew r);
- r
- | _ ->
- invalid())
- | "$int", [{ eexpr = TBinop (OpDiv, e1, e2) }] when is_int (to_type ctx e1.etype) && is_int (to_type ctx e2.etype) ->
- let tmp = alloc_tmp ctx HI32 in
- let r1 = eval_to ctx e1 HI32 in
- hold ctx r1;
- let r2 = eval_to ctx e2 HI32 in
- free ctx r1;
- op ctx (if unsigned_op e1 e2 then OUDiv (tmp,r1,r2) else OSDiv (tmp, r1, r2));
- tmp
- | "$int", [e] ->
- let tmp = alloc_tmp ctx HI32 in
- op ctx (OToInt (tmp, eval_expr ctx e));
- tmp
- | "$bsetui8", [b;pos;v] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- hold ctx pos;
- let r = eval_to ctx v HI32 in
- free ctx pos;
- free ctx b;
- op ctx (OSetUI8 (b, pos, r));
- r
- | "$bsetui16", [b;pos;v] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- hold ctx pos;
- let r = eval_to ctx v HI32 in
- free ctx pos;
- free ctx b;
- op ctx (OSetUI16 (b, pos, r));
- r
- | "$bseti32", [b;pos;v] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- hold ctx pos;
- let r = eval_to ctx v HI32 in
- free ctx pos;
- free ctx b;
- op ctx (OSetMem (b, pos, r));
- r
- | "$bseti64", [b;pos;v] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- hold ctx pos;
- let r = eval_to ctx v HI64 in
- free ctx pos;
- free ctx b;
- op ctx (OSetMem (b, pos, r));
- r
- | "$bsetf32", [b;pos;v] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- hold ctx pos;
- let r = eval_to ctx v HF32 in
- free ctx pos;
- free ctx b;
- op ctx (OSetMem (b, pos, r));
- r
- | "$bsetf64", [b;pos;v] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- hold ctx pos;
- let r = eval_to ctx v HF64 in
- free ctx pos;
- free ctx b;
- op ctx (OSetMem (b, pos, r));
- r
- | "$bytes_sizebits", [eb] ->
- (match follow eb.etype with
- | TAbstract({a_path = ["hl"],"BytesAccess"},[t]) ->
- reg_int ctx (match to_type ctx t with
- | HUI8 -> 0
- | HUI16 -> 1
- | HI32 | HF32 -> 2
- | HI64 | HF64 -> 3
- | t -> abort ("Unsupported basic type " ^ tstr t) e.epos)
- | _ ->
- abort "Invalid BytesAccess" eb.epos);
- | "$bytes_nullvalue", [eb] ->
- (match follow eb.etype with
- | TAbstract({a_path = ["hl"],"BytesAccess"},[t]) ->
- let t = to_type ctx t in
- let r = alloc_tmp ctx t in
- (match t with
- | HUI8 | HUI16 | HI32 | HI64 ->
- op ctx (OInt (r,alloc_i32 ctx 0l))
- | HF32 | HF64 ->
- op ctx (OFloat (r, alloc_float ctx 0.))
- | t ->
- abort ("Unsupported basic type " ^ tstr t) e.epos);
- r
- | _ ->
- abort "Invalid BytesAccess" eb.epos);
- | "$bget", [eb;pos] ->
- (match follow eb.etype with
- | TAbstract({a_path = ["hl"],"BytesAccess"},[t]) ->
- let b = eval_to ctx eb HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- free ctx b;
- let t = to_type ctx t in
- (match t with
- | HUI8 ->
- let r = alloc_tmp ctx HI32 in
- op ctx (OGetUI8 (r, b, pos));
- r
- | HUI16 ->
- let r = alloc_tmp ctx HI32 in
- op ctx (OGetUI16 (r, b, shl ctx pos 1));
- r
- | HI32 ->
- let r = alloc_tmp ctx HI32 in
- op ctx (OGetMem (r, b, shl ctx pos 2));
- r
- | HI64 ->
- let r = alloc_tmp ctx HI64 in
- op ctx (OGetMem (r, b, shl ctx pos 3));
- r
- | HF32 ->
- let r = alloc_tmp ctx HF32 in
- op ctx (OGetMem (r, b, shl ctx pos 2));
- r
- | HF64 ->
- let r = alloc_tmp ctx HF64 in
- op ctx (OGetMem (r, b, shl ctx pos 3));
- r
- | _ ->
- abort ("Unsupported basic type " ^ tstr t) e.epos)
- | _ ->
- abort "Invalid BytesAccess" eb.epos);
- | "$bset", [eb;pos;value] ->
- (match follow eb.etype with
- | TAbstract({a_path = ["hl"],"BytesAccess"},[t]) ->
- let b = eval_to ctx eb HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- hold ctx pos;
- let t = to_type ctx t in
- let v = (match t with
- | HUI8 ->
- let v = eval_to ctx value HI32 in
- op ctx (OSetUI8 (b, pos, v));
- v
- | HUI16 ->
- let v = eval_to ctx value HI32 in
- hold ctx v;
- op ctx (OSetUI16 (b, shl ctx pos 1, v));
- free ctx v;
- v
- | HI32 ->
- let v = eval_to ctx value HI32 in
- hold ctx v;
- op ctx (OSetMem (b, shl ctx pos 2, v));
- free ctx v;
- v
- | HI64 ->
- let v = eval_to ctx value HI64 in
- hold ctx v;
- op ctx (OSetMem (b, shl ctx pos 3, v));
- free ctx v;
- v
- | HF32 ->
- let v = eval_to ctx value HF32 in
- hold ctx v;
- op ctx (OSetMem (b, shl ctx pos 2, v));
- free ctx v;
- v
- | HF64 ->
- let v = eval_to ctx value HF64 in
- hold ctx v;
- op ctx (OSetMem (b, shl ctx pos 3, v));
- free ctx v;
- v
- | _ ->
- abort ("Unsupported basic type " ^ tstr t) e.epos
- ) in
- free ctx b;
- free ctx pos;
- v
- | _ ->
- abort "Invalid BytesAccess" eb.epos);
- | "$bgetui8", [b;pos] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- free ctx b;
- let r = alloc_tmp ctx HI32 in
- op ctx (OGetUI8 (r, b, pos));
- r
- | "$bgetui16", [b;pos] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- free ctx b;
- let r = alloc_tmp ctx HI32 in
- op ctx (OGetUI16 (r, b, pos));
- r
- | "$bgeti32", [b;pos] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- free ctx b;
- let r = alloc_tmp ctx HI32 in
- op ctx (OGetMem (r, b, pos));
- r
- | "$bgeti64", [b;pos] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- free ctx b;
- let r = alloc_tmp ctx HI64 in
- op ctx (OGetMem (r, b, pos));
- r
- | "$bgetf32", [b;pos] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- free ctx b;
- let r = alloc_tmp ctx HF32 in
- op ctx (OGetMem (r, b, pos));
- r
- | "$bgetf64", [b;pos] ->
- let b = eval_to ctx b HBytes in
- hold ctx b;
- let pos = eval_to ctx pos HI32 in
- free ctx b;
- let r = alloc_tmp ctx HF64 in
- op ctx (OGetMem (r, b, pos));
- r
- | "$asize", [e] ->
- let r = alloc_tmp ctx HI32 in
- (match follow e.etype with
- | TInst ({cl_path=["hl"],"Abstract"},[TInst({ cl_kind = KExpr (EConst (String("hl_carray",_)),_) },_)]) ->
- let arr = eval_expr ctx e in
- op ctx (ONullCheck arr);
- op ctx (OArraySize (r, arr))
- | TAbstract ({ a_path = ["hl"],"NativeArray" },[t]) ->
- op ctx (OArraySize (r, eval_to ctx e (HArray (to_type ctx t))))
- | _ ->
- invalid());
- r
- | "$aalloc", [esize] ->
- let et = (match follow e.etype with TAbstract ({ a_path = ["hl"],"NativeArray" },[t]) -> to_type ctx t | _ -> invalid()) in
- let size = eval_to ctx esize HI32 in
- alloc_array ctx size et
- | "$aget", [a; pos] ->
- (*
- read/write on arrays are unsafe : the type of NativeArray needs to be correcly set.
- *)
- let at = (match follow a.etype with TAbstract ({ a_path = ["hl"],"NativeArray" },[t]) -> to_type ctx t | _ -> invalid()) in
- let arr = eval_to ctx a (HArray at) in
- hold ctx arr;
- let pos = eval_to ctx pos HI32 in
- free ctx arr;
- let r = if is_array_type at then alloc_tmp ctx HDyn else alloc_tmp ctx at in
- op ctx (OGetArray (r, arr, pos));
- cast_to ctx r (to_type ctx e.etype) e.epos
- | "$aset", [a; pos; value] ->
- let et = (match follow a.etype with TAbstract ({ a_path = ["hl"],"NativeArray" },[t]) -> to_type ctx t | _ -> invalid()) in
- let arr = eval_to ctx a (HArray et) in
- hold ctx arr;
- let pos = eval_to ctx pos HI32 in
- hold ctx pos;
- let r = eval_to ctx value et in
- free ctx pos;
- free ctx arr;
- op ctx (OSetArray (arr, pos, r));
- r
- | "$abytes", [a] ->
- (match follow a.etype with
- | TInst ({ cl_path = [], "Array" },[t]) when is_number (to_type ctx t) ->
- let a = eval_expr ctx a in
- let r = alloc_tmp ctx HBytes in
- op ctx (ONullCheck a);
- op ctx (OField (r,a,1));
- r
- | t ->
- abort ("Invalid array type " ^ s_type (print_context()) t) a.epos)
- | "$ref", [v] ->
- (match v.eexpr with
- | TLocal v ->
- let r = alloc_tmp ctx (to_type ctx e.etype) in
- let rv = (match rtype ctx r with HRef t -> alloc_var ctx v false | _ -> invalid()) in
- hold ctx rv; (* infinite hold *)
- op ctx (ORef (r,rv));
- r
- | _ ->
- abort "Ref should be a local variable" v.epos)
- | "$setref", [e1;e2] ->
- let rec loop e = match e.eexpr with
- | TParenthesis e1 | TMeta(_,e1) | TCast(e1,None) -> loop e1
- | TLocal v -> v
- | _ -> invalid()
- in
- let v = loop e1 in
- let r = alloc_var ctx v false in
- let rv = eval_to ctx e2 (match rtype ctx r with HRef t -> t | _ -> invalid()) in
- op ctx (OSetref (r,rv));
- r
- | "$unref", [e1] ->
- let rec loop e = match e.eexpr with
- | TParenthesis e1 | TMeta(_,e1) | TCast(e1,None) -> loop e1
- | TLocal v -> v
- | _ -> invalid()
- in
- let v = loop e1 in
- let r = alloc_var ctx v false in
- let out = alloc_tmp ctx (match rtype ctx r with HRef t -> t | _ -> invalid()) in
- op ctx (OUnref (out,r));
- out
- | "$refdata", [e1] ->
- let v = eval_expr ctx e1 in
- let r = alloc_tmp ctx (match to_type ctx e.etype with HRef _ as t -> t | _ -> invalid()) in
- op ctx (ORefData (r,v));
- r
- | "$refoffset", [r;e1] ->
- let r = eval_expr ctx r in
- let e = eval_to ctx e1 HI32 in
- let r2 = alloc_tmp ctx (match rtype ctx r with HRef _ as t -> t | _ -> invalid()) in
- op ctx (ORefOffset (r2,r,e));
- r2
- | "$ttype", [v] ->
- let r = alloc_tmp ctx HType in
- op ctx (OType (r,to_type ctx v.etype));
- r
- | "$tdyntype", [v] ->
- let r = alloc_tmp ctx HType in
- op ctx (OGetType (r,eval_to ctx v HDyn));
- r
- | "$tkind", [v] ->
- let r = alloc_tmp ctx HI32 in
- op ctx (OGetTID (r,eval_to ctx v HType));
- r
- | "$resources", [] ->
- let tdef = (try List.find (fun t -> (t_infos t).mt_path = (["haxe";"_Resource"],"ResourceContent")) ctx.com.types with Not_found -> die "" __LOC__) in
- let t = class_type ctx (match tdef with TClassDecl c -> c | _ -> die "" __LOC__) [] false in
- let res = Hashtbl.fold (fun k v acc -> (k,v) :: acc) ctx.com.resources [] in
- let size = reg_int ctx (List.length res) in
- let arr = alloc_array ctx size HBytes in
- let ro = alloc_tmp ctx t in
- let rb = alloc_tmp ctx HBytes in
- let ridx = reg_int ctx 0 in
- hold ctx ridx;
- let has_len = (match t with HObj p -> PMap.mem "dataLen" p.pindex | _ -> die "" __LOC__) in
- list_iteri (fun i (k,v) ->
- op ctx (ONew ro);
- op ctx (OString (rb,alloc_string ctx k));
- op ctx (OSetField (ro,0,rb));
- (* fix for Resource.getString *)
- let str = try ignore(String.index v '\x00'); v with Not_found -> v ^ "\x00" in
- op ctx (OBytes (rb,alloc_bytes ctx (Bytes.of_string str)));
- op ctx (OSetField (ro,1,rb));
- if has_len then op ctx (OSetField (ro,2,reg_int ctx (String.length v)));
- op ctx (OSetArray (arr,ridx,ro));
- op ctx (OIncr ridx);
- ) res;
- free ctx ridx;
- arr
- | "$rethrow", [v] ->
- let r = alloc_tmp ctx HVoid in
- op ctx (ORethrow (eval_to ctx v HDyn));
- r
- | "$allTypes", [] ->
- let r = alloc_tmp ctx (to_type ctx e.etype) in
- op ctx (OGetGlobal (r, alloc_global ctx "__types__" (rtype ctx r)));
- r
- | "$allTypes", [v] ->
- let v = eval_expr ctx v in
- op ctx (OSetGlobal (alloc_global ctx "__types__" (rtype ctx v), v));
- v
- | "$hash", [v] ->
- (match v.eexpr with
- | TConst (TString str) ->
- let r = alloc_tmp ctx HI32 in
- op ctx (OInt (r,alloc_i32 ctx (hl_hash str)));
- r
- | _ -> abort "Constant string required" v.epos)
- | "$enumIndex", [v] ->
- get_enum_index ctx v
- | "$__mk_pos__", [{ eexpr = TConst (TString file) };min;max] ->
- (* macros only - generated by reification *)
- let rt = HAbstract ("macro_pos",alloc_string ctx "macro_pos") in
- let r = alloc_tmp ctx rt in
- let rfile = alloc_tmp ctx HBytes in
- op ctx (OBytes (rfile, alloc_bytes ctx (Bytes.of_string file)));
- hold ctx rfile;
- let min = eval_expr ctx min in hold ctx min;
- let max = eval_expr ctx max in
- op ctx (OCall3 (r,alloc_std ctx "make_macro_pos" [HBytes;HI32;HI32] rt,rfile,min,max));
- free ctx rfile;
- free ctx min;
- r
- | "$prefetch", [value; mode] ->
- let mode = (match get_const mode with
- | TInt m -> Int32.to_int m
- | _ -> abort "Constant mode required" e.epos
- ) in
- (match get_access ctx value with
- | AInstanceField (f, index) -> op ctx (OPrefetch (eval_expr ctx f, index + 1, mode))
- | _ -> op ctx (OPrefetch (eval_expr ctx value, 0, mode)));
- alloc_tmp ctx HVoid
- | "$unsafecast", [value] ->
- let r = alloc_tmp ctx (to_type ctx e.etype) in
- op ctx (OUnsafeCast (r, eval_expr ctx value));
- r
- | "$asm", [mode; value] ->
- let mode = (match get_const mode with
- | TInt m -> Int32.to_int m
- | _ -> abort "Constant mode required" e.epos
- ) in
- let value = (match get_const value with
- | TInt m -> Int32.to_int m
- | _ -> abort "Constant value required" e.epos
- ) in
- op ctx (OAsm (mode, value, 0));
- alloc_tmp ctx HVoid
- | "$asm", [mode; value; reg] ->
- let mode = (match get_const mode with
- | TInt m -> Int32.to_int m
- | _ -> abort "Constant mode required" e.epos
- ) in
- let value = (match get_const value with
- | TInt m -> Int32.to_int m
- | _ -> abort "Constant value required" e.epos
- ) in
- op ctx (OAsm (mode, value, (eval_expr ctx reg) + 1));
- alloc_tmp ctx HVoid
- | _ ->
- abort ("Unknown native call " ^ s) e.epos)
- | TEnumIndex v ->
- get_enum_index ctx v
- | TCall ({ eexpr = TField (_,FStatic ({ cl_path = [],"Type" },{ cf_name = "enumIndex" })) },[{ eexpr = TCast(v,_) }]) when (match follow v.etype with TEnum _ -> true | _ -> false) ->
- get_enum_index ctx v
- | TCall ({ eexpr = TField (_,FStatic ({ cl_path = [],"Type" },{ cf_name = "enumIndex" })) },[v]) when (match follow v.etype with TEnum _ -> true | _ -> false) ->
- get_enum_index ctx v
- | TCall ({ eexpr = TField (ef,FStatic ({ cl_path = [],"Reflect" } as c,{ cf_name = "makeVarArgs" })) } as e1,[v]) ->
- eval_expr ctx {e with eexpr = TCall({e1 with eexpr = TField(ef,FStatic(c, PMap.find "_makeVarArgs" c.cl_statics))},[v])}
- | TCall ({ eexpr = TField (_,FStatic ({ cl_path = [],"Std" },{ cf_name = "instance" })) },[v;vt])
- | TCall ({ eexpr = TField (_,FStatic ({ cl_path = [],"Std" },{ cf_name = "downcast" })) },[v;vt]) ->
- let r = eval_expr ctx v in
- hold ctx r;
- let c = eval_to ctx vt (class_type ctx ctx.base_type [] false) in
- hold ctx c;
- let rv = alloc_tmp ctx (to_type ctx e.etype) in
- let rb = alloc_tmp ctx HBool in
- op ctx (OCall2 (rb, alloc_fun_path ctx (["hl"],"BaseType") "check",c,r));
- let jnext = jump ctx (fun n -> OJFalse (rb,n)) in
- op ctx (OMov (rv, unsafe_cast_to ~debugchk:false ctx r (to_type ctx e.etype) e.epos));
- let jend = jump ctx (fun n -> OJAlways n) in
- jnext();
- op ctx (ONull rv);
- jend();
- free ctx r;
- free ctx c;
- rv
- | TCall (ec,args) ->
- let tfun = real_type ctx ec in
- let el() = eval_args ctx args tfun e.epos in
- let ret = alloc_tmp ctx (match tfun with HFun (_,r) -> r | _ -> HDyn) in
- let def_ret = ref None in
- (match get_access ctx ec with
- | AStaticFun f ->
- (match el() with
- | [] -> op ctx (OCall0 (ret, f))
- | [a] -> op ctx (OCall1 (ret, f, a))
- | [a;b] -> op ctx (OCall2 (ret, f, a, b))
- | [a;b;c] -> op ctx (OCall3 (ret, f, a, b, c))
- | [a;b;c;d] -> op ctx (OCall4 (ret, f, a, b, c, d))
- | el -> op ctx (OCallN (ret, f, el)));
- | AInstanceFun (ethis, f) ->
- let r = eval_null_check ctx ethis in
- hold ctx r;
- let el = r :: el() in
- free ctx r;
- (match el with
- | [a] -> op ctx (OCall1 (ret, f, a))
- | [a;b] -> op ctx (OCall2 (ret, f, a, b))
- | [a;b;c] -> op ctx (OCall3 (ret, f, a, b, c))
- | [a;b;c;d] -> op ctx (OCall4 (ret, f, a, b, c, d))
- | _ -> op ctx (OCallN (ret, f, el)));
- | AInstanceProto ({ eexpr = TConst TThis }, fid) ->
- op ctx (OCallThis (ret, fid, el()))
- | AInstanceProto (ethis, fid) | AVirtualMethod (ethis, fid) ->
- let r = eval_null_check ctx ethis in
- hold ctx r;
- let el = r :: el() in
- free ctx r;
- op ctx (OCallMethod (ret, fid, el))
- | AEnum (_,index) ->
- op ctx (OMakeEnum (ret, index, el()))
- | AArray (a,t,idx) ->
- let r = array_read ctx a t idx ec.epos in
- hold ctx r;
- op ctx (ONullCheck r);
- op ctx (OCallClosure (ret, r, el())); (* if it's a value, it's a closure *)
- free ctx r;
- | _ ->
- (* don't use real_type here *)
- let tfun = to_type ctx ec.etype in
- let r = eval_null_check ctx ec in
- hold ctx r;
- let el = eval_args ctx args tfun e.epos in
- free ctx r;
- let ret = alloc_tmp ctx (match tfun with HFun (_,r) -> r | _ -> HDyn) in
- op ctx (OCallClosure (ret, r, el)); (* if it's a value, it's a closure *)
- def_ret := Some (cast_to ~force:true ctx ret (to_type ctx e.etype) e.epos);
- );
- (match !def_ret with
- | None ->
- let rt = to_type ctx e.etype in
- let is_valid_method t =
- match follow t with
- | TFun (_,rt) ->
- (match follow rt with
- | TInst({ cl_kind = KTypeParameter ttp },_) ->
- (* don't allow if we have a constraint virtual, see hxbit.Serializer.getRef *)
- not (List.exists (fun t -> match to_type ctx t with HVirtual _ -> true | _ -> false) (get_constraints ttp))
- | _ -> false)
- | _ ->
- false
- in
- (match ec.eexpr with
- | TField (_, FInstance(_,_,{ cf_kind = Method (MethNormal|MethInline); cf_type = t })) when is_valid_method t ->
- (* let's trust the compiler when it comes to casting the return value from a type parameter *)
- unsafe_cast_to ctx ret rt e.epos
- | _ ->
- cast_to ~force:true ctx ret rt e.epos)
- | Some r ->
- r)
- | TField (ec,FInstance({ cl_path = [],"Array" },[t],{ cf_name = "length" })) when to_type ctx t = HDyn ->
- let r = alloc_tmp ctx HI32 in
- op ctx (OCall1 (r,alloc_fun_path ctx (["hl";"types"],"ArrayDyn") "get_length", eval_null_check ctx ec));
- r
- | TField (ec,a) ->
- let r = alloc_tmp ctx (to_type ctx (field_type ctx a e.epos)) in
- (match get_access ctx e with
- | AGlobal g ->
- op ctx (OGetGlobal (r,g));
- | AStaticVar (g,t,fid) ->
- let o = alloc_tmp ctx t in
- op ctx (OGetGlobal (o,g));
- op ctx (OField (r,o,fid));
- | AStaticFun f ->
- op ctx (OStaticClosure (r,f));
- | AInstanceFun (ethis, f) ->
- op ctx (OInstanceClosure (r, f, eval_null_check ctx ethis))
- | AInstanceField (ethis,fid) ->
- let robj = eval_null_check ctx ethis in
- op ctx (match ethis.eexpr with TConst TThis -> OGetThis (r,fid) | _ -> OField (r,robj,fid));
- | AInstanceProto (ethis,fid) | AVirtualMethod (ethis, fid) ->
- let robj = eval_null_check ctx ethis in
- (match rtype ctx robj with
- | HObj _ ->
- op ctx (OVirtualClosure (r,robj,fid))
- | HVirtual vp ->
- let _, sid, _ = vp.vfields.(fid) in
- op ctx (ODynGet (r,robj, sid))
- | _ ->
- die "" __LOC__)
- | ADynamic (ethis, f) ->
- let robj = eval_null_check ctx ethis in
- op ctx (ODynGet (r,robj,f))
- | AEnum (en,index) ->
- let cur_fid = DynArray.length ctx.cfids.arr in
- let name = List.nth en.e_names index in
- let fid = alloc_fun_path ctx en.e_path name in
- if fid = cur_fid then begin
- let ef = PMap.find name en.e_constrs in
- let eargs, et = (match follow ef.ef_type with TFun (args,ret) -> args, ret | _ -> die "" __LOC__) in
- let ct = ctx.com.basic in
- let p = ef.ef_pos in
- 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
- let ecall = mk (TCall (e,List.map (fun (v,_) -> mk (TLocal v) v.v_type p) eargs)) et p in
- let f = {
- tf_args = eargs;
- tf_type = et;
- tf_expr = mk (TReturn (Some ecall)) ct.tvoid p;
- } in
- ignore(make_fun ctx ("","") fid f None None);
- end;
- op ctx (OStaticClosure (r,fid));
- | ANone | ALocal _ | AArray _ | ACaptured _ | ACArray _ ->
- abort "Invalid access" e.epos);
- let to_t = to_type ctx e.etype in
- (match to_t with
- | HFun _ -> cast_to ctx r to_t e.epos
- | _ -> unsafe_cast_to ctx r to_t e.epos)
- | TObjectDecl fl ->
- (match to_type ctx e.etype with
- | 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) ->
- let r = alloc_tmp ctx t in
- op ctx (ONew r);
- hold ctx r;
- List.iter (fun ((s,_,_),ev) ->
- let fidx = (try PMap.find s vp.vindex with Not_found -> die "" __LOC__) in
- let _, _, ft = vp.vfields.(fidx) in
- let v = eval_to ctx ev ft in
- op ctx (OSetField (r,fidx,v));
- ) fl;
- free ctx r;
- r
- | _ ->
- let r = alloc_tmp ctx HDynObj in
- op ctx (ONew r);
- hold ctx r;
- let a = (match follow e.etype with TAnon a -> Some a | t -> if t == t_dynamic then None else die "" __LOC__) in
- List.iter (fun ((s,_,_),ev) ->
- 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
- let v = eval_to ctx ev (to_type ctx ft) in
- op ctx (ODynSet (r,alloc_string ctx s,v));
- if s = "toString" && is_to_string ev.etype then begin
- let f = alloc_tmp ctx (HFun ([],HBytes)) in
- op ctx (OInstanceClosure (f, alloc_fun_path ctx ([],"String") "call_toString", r));
- op ctx (ODynSet (r,alloc_string ctx "__string",f));
- end;
- ) fl;
- free ctx r;
- cast_to ctx r (to_type ctx e.etype) e.epos)
- | TNew (c,pl,el) ->
- let c = resolve_class ctx c pl false in
- let r = alloc_tmp ctx (class_type ctx c pl false) in
- op ctx (ONew r);
- hold ctx r;
- (match c.cl_constructor with
- | None -> if c.cl_implements <> [] then die "" __LOC__
- | Some { cf_expr = None } -> abort (s_type_path c.cl_path ^ " does not have a constructor") e.epos
- | Some ({ cf_expr = Some cexpr } as constr) ->
- let rl = eval_args ctx el (to_type ctx cexpr.etype) e.epos in
- let ret = alloc_tmp ctx HVoid in
- let g = alloc_fid ctx c constr in
- op ctx (match rl with
- | [] -> OCall1 (ret,g,r)
- | [a] -> OCall2 (ret,g,r,a)
- | [a;b] -> OCall3 (ret,g,r,a,b)
- | [a;b;c] -> OCall4 (ret,g,r,a,b,c)
- | _ -> OCallN (ret,g,r :: rl));
- );
- free ctx r;
- r
- | TIf (cond,eif,eelse) ->
- let t = to_type ctx e.etype in
- let out = alloc_tmp ctx t in
- let j = jump_expr ctx cond false in
- let rif = if t = HVoid then eval_expr ctx eif else eval_to ctx eif t in
- set_curpos ctx (max_pos eif);
- if t <> HVoid then op ctx (OMov (out,rif));
- (match eelse with
- | None -> j()
- | Some e ->
- let jexit = jump ctx (fun i -> OJAlways i) in
- j();
- if t = HVoid then ignore(eval_expr ctx e) else op ctx (OMov (out,eval_to ctx e t));
- jexit());
- out
- | TBinop (bop, e1, e2) ->
- let arithbinop r a b =
- let rec loop bop =
- match bop with
- | OpAdd ->
- (match rtype ctx r with
- | HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 ->
- op ctx (OAdd (r,a,b))
- | HObj { pname = "String" } ->
- op ctx (OCall2 (r,alloc_fun_path ctx ([],"String") "__add__",to_string ctx a e1.epos,to_string ctx b e2.epos))
- | HDyn ->
- op ctx (OCall2 (r,alloc_fun_path ctx ([],"Std") "__add__",a,b))
- | t ->
- abort ("Cannot add " ^ tstr t) e.epos)
- | OpSub | OpMult | OpMod | OpDiv ->
- (match rtype ctx r with
- | HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 ->
- (match bop with
- | OpSub -> op ctx (OSub (r,a,b))
- | OpMult -> op ctx (OMul (r,a,b))
- | OpMod -> op ctx (if unsigned e1.etype then OUMod (r,a,b) else OSMod (r,a,b))
- | OpDiv -> op ctx (OSDiv (r,a,b)) (* don't use UDiv since both operands are float already *)
- | _ -> die "" __LOC__)
- | HDyn ->
- 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))
- | _ ->
- die "" __LOC__)
- | OpShl | OpShr | OpUShr | OpAnd | OpOr | OpXor ->
- (match rtype ctx r with
- | HUI8 | HUI16 | HI32 | HI64 ->
- (match bop with
- | OpShl -> op ctx (OShl (r,a,b))
- | OpShr -> op ctx (if unsigned e1.etype then OUShr (r,a,b) else OSShr (r,a,b))
- | OpUShr -> op ctx (OUShr (r,a,b))
- | OpAnd -> op ctx (OAnd (r,a,b))
- | OpOr -> op ctx (OOr (r,a,b))
- | OpXor -> op ctx (OXor (r,a,b))
- | _ -> ())
- | HDyn ->
- 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))
- | _ ->
- die "" __LOC__)
- | OpAssignOp bop ->
- loop bop
- | _ ->
- die "" __LOC__
- in
- loop bop
- in
- (match bop with
- | OpLte | OpGt | OpGte | OpLt | OpEq | OpNotEq ->
- let r = alloc_tmp ctx HBool in
- let j = jump_expr ctx e false in
- op ctx (OBool (r, true));
- op ctx (OJAlways 1);
- j();
- op ctx (OBool (r, false));
- r
- | OpAdd | OpSub | OpMult | OpDiv | OpMod | OpShl | OpShr | OpUShr | OpAnd | OpOr | OpXor ->
- let t = (match to_type ctx e.etype with HNull t -> t | t -> t) in
- let conv_string = bop = OpAdd && is_string t in
- let eval e =
- if conv_string then
- let r = eval_expr ctx e in
- to_string ctx r e.epos
- else
- eval_to ctx e t
- in
- let r = alloc_tmp ctx t in
- let a = eval e1 in
- hold ctx a;
- let b = eval e2 in
- free ctx a;
- arithbinop r a b;
- r
- | OpAssign ->
- let value() = eval_to ctx e2 (real_type ctx e1) in
- (match get_access ctx e1 with
- | AGlobal g ->
- let r = value() in
- op ctx (OSetGlobal (g,r));
- r
- | AStaticVar (g,t,fid) ->
- let r = value() in
- hold ctx r;
- let o = alloc_tmp ctx t in
- free ctx r;
- op ctx (OGetGlobal (o, g));
- op ctx (OSetField (o, fid, r));
- r
- | AInstanceField ({ eexpr = TConst TThis }, fid) ->
- let r = value() in
- op ctx (OSetThis (fid,r));
- r
- | AInstanceField (ethis, fid) ->
- let rthis = eval_null_check ctx ethis in
- hold ctx rthis;
- let r = value() in
- free ctx rthis;
- op ctx (OSetField (rthis, fid, r));
- r
- | ALocal (v,l) ->
- let r = value() in
- push_op ctx (OMov (l, r));
- add_assign ctx v;
- r
- | AArray (ra,(at,vt),ridx) ->
- hold ctx ra;
- hold ctx ridx;
- let v = cast_to ctx (value()) (match at with HUI16 | HUI8 -> HI32 | _ -> at) e.epos in
- hold ctx v;
- (* bounds check against length *)
- (match at with
- | HDyn ->
- (* call setDyn() *)
- op ctx (OCallMethod (alloc_tmp ctx HVoid,1,[ra;ridx;cast_to ctx v (if is_dynamic at then at else HDyn) e.epos]));
- | _ ->
- let len = alloc_tmp ctx HI32 in
- op ctx (OField (len,ra,0)); (* length *)
- let j = jump ctx (fun i -> OJULt (ridx,len,i)) in
- op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx (array_class ctx at).cl_path "__expand", ra, ridx));
- j();
- match at with
- | HI32 | HF64 | HUI16 | HF32 | HI64 ->
- let b = alloc_tmp ctx HBytes in
- op ctx (OField (b,ra,1));
- write_mem ctx b (shl ctx ridx (type_size_bits at)) at v
- | _ ->
- let arr = alloc_tmp ctx (HArray vt) in
- op ctx (OField (arr,ra,1));
- op ctx (OSetArray (arr,ridx,cast_to ctx v (if is_dynamic at then at else HDyn) e.epos))
- );
- free ctx v;
- free ctx ra;
- free ctx ridx;
- v
- | ACArray (ra, _, ridx) ->
- hold ctx ra;
- hold ctx ridx;
- let v = value() in
- op ctx (OSetArray (ra,ridx,v));
- free ctx ridx;
- free ctx ra;
- v
- | ADynamic (ethis,f) ->
- let obj = eval_null_check ctx ethis in
- hold ctx obj;
- let r = eval_expr ctx e2 in
- free ctx obj;
- op ctx (ODynSet (obj,f,r));
- r
- | ACaptured index ->
- let r = value() in
- op ctx (OSetEnumField (ctx.m.mcaptreg,index,r));
- r
- | AEnum _ | ANone | AInstanceFun _ | AInstanceProto _ | AStaticFun _ | AVirtualMethod _ ->
- die "" __LOC__)
- | OpBoolOr ->
- let r = alloc_tmp ctx HBool in
- let j = jump_expr ctx e1 true in
- let j2 = jump_expr ctx e2 true in
- op ctx (OBool (r,false));
- let jend = jump ctx (fun b -> OJAlways b) in
- j();
- j2();
- op ctx (OBool (r,true));
- jend();
- r
- | OpBoolAnd ->
- let r = alloc_tmp ctx HBool in
- let j = jump_expr ctx e1 false in
- let j2 = jump_expr ctx e2 false in
- op ctx (OBool (r,true));
- let jend = jump ctx (fun b -> OJAlways b) in
- j();
- j2();
- op ctx (OBool (r,false));
- jend();
- r
- | OpAssignOp bop ->
- (match get_access ctx e1 with
- | ALocal (v,l) ->
- let r = eval_to ctx { e with eexpr = TBinop (bop,e1,e2) } (to_type ctx e1.etype) in
- push_op ctx (OMov (l, r));
- add_assign ctx v;
- r
- | acc ->
- gen_assign_op ctx acc e1 (fun r ->
- hold ctx r;
- 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
- free ctx r;
- arithbinop r r b;
- r))
- | OpInterval | OpArrow | OpIn | OpNullCoal ->
- die "" __LOC__)
- | TUnop (Not,_,v) ->
- let tmp = alloc_tmp ctx HBool in
- let r = eval_to ctx v HBool in
- op ctx (ONot (tmp,r));
- tmp
- | TUnop (Neg,_,v) ->
- let t = to_type ctx e.etype in
- let tmp = alloc_tmp ctx t in
- let r = eval_to ctx v t in
- op ctx (ONeg (tmp,r));
- tmp
- | TUnop (Spread,_,_) ->
- die ~p:e.epos "Unexpected spread operator" __LOC__
- | TUnop (NegBits,_,v) ->
- let t = to_type ctx e.etype in
- let tmp = alloc_tmp ctx t in
- let r = eval_to ctx v t in
- let mask = (match t with
- | HUI8 -> 0xFFl
- | HUI16 -> 0xFFFFl
- | HI32 -> 0xFFFFFFFFl
- | _ -> abort ("Unsupported " ^ tstr t) e.epos
- ) in
- hold ctx r;
- let r2 = alloc_tmp ctx t in
- free ctx r;
- op ctx (OInt (r2,alloc_i32 ctx mask));
- op ctx (OXor (tmp,r,r2));
- tmp
- | TUnop (Increment|Decrement as uop,fix,v) ->
- let rec unop r =
- match rtype ctx r with
- | HUI8 | HUI16 | HI32 | HI64 ->
- if uop = Increment then op ctx (OIncr r) else op ctx (ODecr r)
- | HF32 | HF64 as t ->
- hold ctx r;
- let tmp = alloc_tmp ctx t in
- free ctx r;
- op ctx (OFloat (tmp,alloc_float ctx 1.));
- if uop = Increment then op ctx (OAdd (r,r,tmp)) else op ctx (OSub (r,r,tmp))
- | HNull (HUI8 | HUI16 | HI32 | HI64 | HF32 | HF64 as t) ->
- hold ctx r;
- let tmp = alloc_tmp ctx t in
- free ctx r;
- op ctx (OSafeCast (tmp,r));
- unop tmp;
- op ctx (OToDyn (r,tmp));
- | HDyn when uop = Increment ->
- hold ctx r;
- let tmp = alloc_tmp ctx HDyn in
- free ctx r;
- op ctx (OToDyn (tmp, reg_int ctx 1));
- op ctx (OCall2 (r,alloc_fun_path ctx ([],"Std") "__add__",r,tmp))
- | HDyn when uop = Decrement ->
- let r2 = alloc_tmp ctx HF64 in
- hold ctx r2;
- let tmp = alloc_tmp ctx HF64 in
- free ctx r2;
- op ctx (OSafeCast (r2, r));
- op ctx (OFloat (tmp, alloc_float ctx 1.));
- op ctx (OSub (r2, r2, tmp));
- op ctx (OSafeCast (r, r2));
- | _ ->
- die "" __LOC__
- in
- (match get_access ctx v, fix with
- | ALocal (v,r), Prefix ->
- unop r;
- r
- | ALocal (v,r), Postfix ->
- let r2 = alloc_tmp ctx (rtype ctx r) in
- hold ctx r2;
- op ctx (OMov (r2,r));
- unop r;
- free ctx r2;
- r2
- | acc, _ ->
- let ret = ref 0 in
- (match acc with AArray (a,_,idx) -> hold ctx a; hold ctx idx | _ -> ());
- ignore(gen_assign_op ctx acc v (fun r ->
- if fix = Prefix then ret := r else begin
- hold ctx r;
- let tmp = alloc_tmp ctx (rtype ctx r) in
- free ctx r;
- op ctx (OMov (tmp, r));
- ret := tmp;
- end;
- hold ctx !ret;
- unop r;
- r)
- );
- free ctx !ret;
- (match acc with AArray (a,_,idx) -> free ctx a; free ctx idx | _ -> ());
- !ret)
- | TFunction f ->
- let fid = alloc_function_name ctx ("function#" ^ string_of_int (DynArray.length ctx.cfids.arr)) in
- let capt = make_fun ctx ("","") fid f None (Some ctx.m.mcaptured) in
- let r = alloc_tmp ctx (to_type ctx e.etype) in
- if capt == ctx.m.mcaptured then
- op ctx (OInstanceClosure (r, fid, ctx.m.mcaptreg))
- else (match Array.length capt.c_vars with
- | 0 ->
- op ctx (OStaticClosure (r, fid))
- | 1 when not capt.c_group ->
- op ctx (OInstanceClosure (r, fid, eval_var ctx capt.c_vars.(0)))
- | _ ->
- let env = alloc_tmp ctx capt.c_type in
- op ctx (OEnumAlloc (env,0));
- hold ctx env;
- Array.iteri (fun i v -> op ctx (OSetEnumField (env,i,eval_var ctx v))) capt.c_vars;
- free ctx env;
- op ctx (OInstanceClosure (r, fid, env)));
- r
- (* throwing a catch var means we want to rethrow an exception *)
- | TThrow ({ eexpr = TLocal v } as e1) when has_var_flag v VCaught ->
- let r = alloc_tmp ctx HVoid in
- op ctx (ORethrow (eval_to ctx e1 HDyn));
- r
- | TThrow v ->
- op ctx (OThrow (eval_to ctx v HDyn));
- alloc_tmp ctx HDyn
- | TWhile (cond,eloop,NormalWhile) ->
- let oldb = ctx.m.mbreaks and oldc = ctx.m.mcontinues and oldtrys = ctx.m.mloop_trys in
- ctx.m.mbreaks <- [];
- ctx.m.mcontinues <- [];
- ctx.m.mloop_trys <- ctx.m.mtrys;
- let continue_pos = current_pos ctx in
- let ret = jump_back ctx in
- let j = jump_expr ctx cond false in
- ignore(eval_expr ctx eloop);
- set_curpos ctx (max_pos e);
- ret();
- j();
- List.iter (fun f -> f (current_pos ctx)) ctx.m.mbreaks;
- List.iter (fun f -> f continue_pos) ctx.m.mcontinues;
- ctx.m.mbreaks <- oldb;
- ctx.m.mcontinues <- oldc;
- ctx.m.mloop_trys <- oldtrys;
- alloc_tmp ctx HVoid
- | TWhile (cond,eloop,DoWhile) ->
- let oldb = ctx.m.mbreaks and oldc = ctx.m.mcontinues and oldtrys = ctx.m.mloop_trys in
- ctx.m.mbreaks <- [];
- ctx.m.mcontinues <- [];
- ctx.m.mloop_trys <- ctx.m.mtrys;
- let continue_pos = current_pos ctx in
- let ret = jump_back ctx in
- ignore(eval_expr ctx eloop);
- let j = jump_expr ctx cond false in
- ret();
- j();
- List.iter (fun f -> f (current_pos ctx)) ctx.m.mbreaks;
- List.iter (fun f -> f continue_pos) ctx.m.mcontinues;
- ctx.m.mbreaks <- oldb;
- ctx.m.mcontinues <- oldc;
- ctx.m.mloop_trys <- oldtrys;
- alloc_tmp ctx HVoid
- | TCast ({ eexpr = TCast (v,None) },None) when not (is_number (to_type ctx e.etype)) ->
- (* coalesce double casts into a single runtime check - temp fix for Map accesses *)
- eval_expr ctx { e with eexpr = TCast(v,None) }
- | TCast (v,None) ->
- let t = to_type ctx e.etype in
- let rv = eval_expr ctx v in
- (match t with
- | HF32 | HF64 when unsigned v.etype ->
- let r = alloc_tmp ctx t in
- op ctx (OToUFloat (r,rv));
- r
- | HDyn when (match rtype ctx rv with HFun _ -> true | _ -> false) ->
- (* if called, a HDyn method will return HDyn, not its usual return type *)
- let r = alloc_tmp ctx t in
- op ctx (OMov (r,rv));
- r
- | _ ->
- cast_to ~force:true ctx rv t e.epos)
- | TArrayDecl el ->
- let r = alloc_tmp ctx (to_type ctx e.etype) in
- let et = (match follow e.etype with TInst (_,[t]) -> to_type ctx t | _ -> die "" __LOC__) in
- let array_bytes bits t tname get_op =
- let b = alloc_tmp ctx HBytes in
- let size = reg_int ctx ((List.length el) lsl bits) in
- op ctx (OCall1 (b,alloc_std ctx "alloc_bytes" [HI32] HBytes,size));
- let idx = reg_int ctx 0 in
- hold ctx idx;
- hold ctx b;
- list_iteri (fun i e ->
- let r = eval_to ctx e t in
- hold ctx r;
- op ctx (get_op b (shl ctx idx bits) r);
- free ctx r;
- op ctx (OIncr idx);
- ) el;
- free ctx b;
- free ctx idx;
- op ctx (OCall2 (r, alloc_fun_path ctx (["hl";"types"],"ArrayBase") ("alloc" ^ tname), b, reg_int ctx (List.length el)));
- in
- (match et with
- | HI32 ->
- array_bytes 2 HI32 "I32" (fun b i r -> OSetMem (b,i,r))
- | HUI16 ->
- array_bytes 1 HI32 "UI16" (fun b i r -> OSetUI16 (b,i,r))
- | HF32 ->
- array_bytes 2 HF32 "F32" (fun b i r -> OSetMem (b,i,r))
- | HF64 ->
- array_bytes 3 HF64 "F64" (fun b i r -> OSetMem (b,i,r))
- | HI64 ->
- array_bytes 3 HI64 "I64" (fun b i r -> OSetMem (b,i,r))
- | _ ->
- let at = if is_dynamic et then et else HDyn in
- let size = reg_int ctx (List.length el) in
- let a = alloc_array ctx size at in
- hold ctx a;
- list_iteri (fun i e ->
- let r = eval_to ctx e at in
- op ctx (OSetArray (a,reg_int ctx i,r));
- ) el;
- free ctx a;
- let tmp = if et = HDyn then alloc_tmp ctx (class_type ctx ctx.array_impl.aobj [] false) else r in
- op ctx (OCall1 (tmp, alloc_fun_path ctx (["hl";"types"],"ArrayObj") "alloc", a));
- if tmp <> r then begin
- let re = alloc_tmp ctx HBool in
- op ctx (OBool (re,true));
- let ren = alloc_tmp ctx (HRef HBool) in
- op ctx (ORef (ren, re));
- op ctx (OCall2 (r, alloc_fun_path ctx (["hl";"types"],"ArrayDyn") "alloc", tmp, ren));
- end;
- );
- r
- | TArray _ ->
- (match get_access ctx e with
- | AArray (a,at,idx) ->
- array_read ctx a at idx e.epos
- | ACArray (a,t,idx) ->
- let tmp = alloc_tmp ctx t in
- op ctx (OGetArray (tmp,a,idx));
- tmp
- | _ ->
- die "" __LOC__)
- | TMeta (_,e) ->
- eval_expr ctx e
- | TFor (v,it,loop) ->
- eval_expr ctx (Texpr.for_remap ctx.com.basic v it loop e.epos)
- | TSwitch {switch_subject = en;switch_cases = cases;switch_default = def} ->
- let rt = to_type ctx e.etype in
- let r = alloc_tmp ctx rt in
- (try
- let max = ref (-1) in
- let get_int e =
- match e.eexpr with
- | TConst (TInt i) ->
- let v = Int32.to_int i in
- if Int32.of_int v <> i then raise Exit;
- v
- | _ ->
- raise Exit
- in
- List.iter (fun case ->
- List.iter (fun v ->
- let i = get_int v in
- if i < 0 then raise Exit;
- if i > !max then max := i;
- ) case.case_patterns;
- ) cases;
- if !max > 255 || cases = [] then raise Exit;
- let ridx = eval_to ctx en HI32 in
- let indexes = Array.make (!max + 1) 0 in
- op ctx (OSwitch (ridx,indexes,0));
- let switch_pos = current_pos ctx in
- (match def with
- | None ->
- if rt <> HVoid then set_default ctx r;
- | Some e ->
- let re = eval_to ctx e rt in
- if rt <> HVoid then op ctx (OMov (r,re)));
- let jends = ref [jump ctx (fun i -> OJAlways i)] in
- List.iter (fun {case_patterns = values;case_expr = ecase} ->
- List.iter (fun v ->
- Array.set indexes (get_int v) (current_pos ctx - switch_pos)
- ) values;
- let re = eval_to ctx ecase rt in
- if rt <> HVoid then op ctx (OMov (r,re));
- jends := jump ctx (fun i -> OJAlways i) :: !jends
- ) cases;
- set_op ctx (switch_pos - 1) (OSwitch (ridx,indexes,current_pos ctx - switch_pos));
- List.iter (fun j -> j()) (!jends);
- with Exit ->
- let jends = ref [] in
- let rvalue = eval_expr ctx en in
- let loop {case_patterns = cases;case_expr = e} =
- hold ctx rvalue;
- let ok = List.map (fun c ->
- let ct = common_type ctx en c true c.epos in
- match c.eexpr, ct with
- | TConst (TString str), HObj { pname = "String" } ->
- let jnull = jump ctx (fun n -> OJNull (rvalue,n)) in
- (* compare len *)
- let rlen = alloc_tmp ctx HI32 in
- op ctx (OField (rlen, rvalue, 1));
- hold ctx rlen;
- let str, len = to_utf8 str c.epos in
- let rlen2 = reg_int ctx len in
- let jdiff = jump ctx (fun n -> OJNotEq (rlen, rlen2, n)) in
- free ctx rlen;
- (* compare data *)
- let rbytes = alloc_tmp ctx HBytes in
- op ctx (OField (rbytes, rvalue, 0));
- hold ctx rbytes;
- let rbytes2 = alloc_tmp ctx HBytes in
- op ctx (OString (rbytes2,alloc_string ctx str));
- let result = alloc_tmp ctx HI32 in
- op ctx (OCall3 (result, alloc_std ctx "string_compare" [HBytes;HBytes;HI32] HI32,rbytes,rbytes2,rlen));
- free ctx rbytes;
- hold ctx result;
- let zero = reg_int ctx 0 in
- let jok = jump ctx (fun n -> OJEq (result, zero, n)) in
- free ctx result;
- jnull();
- jdiff();
- jok
- | _ ->
- let r = eval_to ctx c ct in
- jump ctx (fun n -> OJEq (r,rvalue,n))
- ) cases in
- free ctx rvalue;
- (fun() ->
- List.iter (fun f -> f()) ok;
- let re = eval_to ctx e rt in
- if rt <> HVoid then op ctx (OMov (r,re));
- jends := jump ctx (fun n -> OJAlways n) :: !jends)
- in
- let all = List.map loop cases in
- (match def with
- | None ->
- if rt <> HVoid then op ctx (ONull r)
- | Some e ->
- let rdef = eval_to ctx e rt in
- if rt <> HVoid then op ctx (OMov (r,rdef)));
- jends := jump ctx (fun n -> OJAlways n) :: !jends;
- List.iter (fun f -> f()) all;
- List.iter (fun j -> j()) (!jends);
- );
- r
- | TEnumParameter (ec,f,index) ->
- let pt, is_single = (match to_type ctx ec.etype with
- | HEnum e ->
- let _,_,args = e.efields.(f.ef_index) in
- args.(index), Array.length e.efields = 1
- | _ -> die "" __LOC__
- ) in
- let er = eval_expr ctx ec in
- if is_single then op ctx (ONullCheck er); (* #7560 *)
- let r = alloc_tmp ctx pt in
- op ctx (OEnumField (r,er,f.ef_index,index));
- cast_to ctx r (to_type ctx e.etype) e.epos
- | TContinue ->
- before_break_continue ctx;
- let pos = current_pos ctx in
- op ctx (OJAlways (-1)); (* loop *)
- ctx.m.mcontinues <- (fun target -> set_op ctx pos (OJAlways (target - (pos + 1)))) :: ctx.m.mcontinues;
- alloc_tmp ctx HVoid
- | TBreak ->
- before_break_continue ctx;
- let pos = current_pos ctx in
- op ctx (OJAlways (-1)); (* loop *)
- ctx.m.mbreaks <- (fun target -> set_op ctx pos (OJAlways (target - (pos + 1)))) :: ctx.m.mbreaks;
- alloc_tmp ctx HVoid
- | TTry (etry,catches) ->
- let pos = current_pos ctx in
- let rtrap = alloc_tmp ctx HDyn in
- op ctx (OTrap (rtrap,-1)); (* loop *)
- ctx.m.mtrys <- ctx.m.mtrys + 1;
- let tret = to_type ctx e.etype in
- let result = alloc_tmp ctx tret in
- let r = eval_expr ctx etry in
- if tret <> HVoid then op ctx (OMov (result,cast_to ctx r tret etry.epos));
- ctx.m.mtrys <- ctx.m.mtrys - 1;
- op ctx (OEndTrap true);
- let j = jump ctx (fun n -> OJAlways n) in
- set_op ctx pos (OTrap (rtrap, current_pos ctx - (pos + 1)));
- let rec loop l =
- match l with
- | [] ->
- op ctx (ORethrow rtrap);
- []
- | (v,ec) :: next ->
- let rv = alloc_var ctx v true in
- let jnext = if follow v.v_type == t_dynamic then begin
- op ctx (OMov (rv, rtrap));
- (fun() -> ())
- end else
- let ct = (match follow v.v_type with
- | TInst (c,_) -> TClassDecl c
- | TAbstract (a,_) -> TAbstractDecl a
- | TEnum (e,_) -> TEnumDecl e
- | _ -> die "" __LOC__
- ) in
- hold ctx rtrap;
- let r = type_value ctx ct ec.epos in
- free ctx rtrap;
- let rb = alloc_tmp ctx HBool in
- op ctx (OCall2 (rb, alloc_fun_path ctx (["hl"],"BaseType") "check",r,rtrap));
- let jnext = jump ctx (fun n -> OJFalse (rb,n)) in
- op ctx (OMov (rv, unsafe_cast_to ~debugchk:false ctx rtrap (to_type ctx v.v_type) ec.epos));
- add_assign ctx v;
- jnext
- in
- let r = eval_expr ctx ec in
- if tret <> HVoid then op ctx (OMov (result,cast_to ctx r tret ec.epos));
- if follow v.v_type == t_dynamic then [] else
- let jend = jump ctx (fun n -> OJAlways n) in
- jnext();
- jend :: loop next
- in
- List.iter (fun j -> j()) (loop catches);
- j();
- result
- | TTypeExpr t ->
- type_value ctx t e.epos
- | TCast (ev,Some _) ->
- let t = to_type ctx e.etype in
- let re = eval_expr ctx ev in
- let rt = alloc_tmp ctx t in
- if safe_cast (rtype ctx re) t then
- op ctx (OMov (rt,re))
- else (match Abstract.follow_with_abstracts e.etype with
- | TInst(c,_) when (has_class_flag c CInterface) ->
- hold ctx re;
- let c = eval_to ctx { eexpr = TTypeExpr(TClassDecl c); epos = e.epos; etype = t_dynamic } (class_type ctx ctx.base_type [] false) in
- hold ctx c;
- let rb = alloc_tmp ctx HBool in
- op ctx (OCall2 (rb, alloc_fun_path ctx (["hl"],"BaseType") "check",c,re));
- let jnext = jump ctx (fun n -> OJTrue (rb,n)) in
- let jnext2 = jump ctx (fun n -> OJNull (re,n)) in
- op ctx (OThrow (make_string ctx "Cast error" e.epos));
- jnext();
- jnext2();
- op ctx (OMov (rt, unsafe_cast_to ~debugchk:false ctx re (to_type ctx e.etype) e.epos));
- free ctx c;
- free ctx re;
- | _ ->
- op ctx (OSafeCast (rt,re)));
- rt
- | TIdent s ->
- abort ("Unbound identifier " ^ s) e.epos
- and gen_assign_op ctx acc e1 f =
- let f r =
- match rtype ctx r with
- | HNull t ->
- let r2 = alloc_tmp ctx t in
- op ctx (OSafeCast (r2,r));
- let r3 = alloc_tmp ctx (HNull t) in
- op ctx (OToDyn (r3,f r2));
- r3
- | _ ->
- f r
- in
- match acc with
- | AInstanceField (eobj, findex) ->
- let robj = eval_null_check ctx eobj in
- hold ctx robj;
- let t = real_type ctx e1 in
- let r = alloc_tmp ctx t in
- op ctx (OField (r,robj,findex));
- let r = cast_to ctx r (to_type ctx e1.etype) e1.epos in
- let r = f r in
- free ctx robj;
- op ctx (OSetField (robj,findex,cast_to ctx r t e1.epos));
- r
- | AStaticVar (g,t,fid) ->
- let o = alloc_tmp ctx t in
- op ctx (OGetGlobal (o,g));
- let r = alloc_tmp ctx (to_type ctx e1.etype) in
- op ctx (OField (r,o,fid));
- hold ctx o;
- let r = f r in
- free ctx o;
- op ctx (OSetField (o,fid,r));
- r
- | AGlobal g ->
- let r = alloc_tmp ctx (to_type ctx e1.etype) in
- op ctx (OGetGlobal (r,g));
- let r = f r in
- op ctx (OSetGlobal (g,r));
- r
- | ACaptured idx ->
- let r = alloc_tmp ctx (to_type ctx e1.etype) in
- op ctx (OEnumField (r, ctx.m.mcaptreg, 0, idx));
- let r = f r in
- op ctx (OSetEnumField (ctx.m.mcaptreg,idx,r));
- r
- | AArray (ra,(at,vt),ridx) ->
- hold ctx ra;
- hold ctx ridx;
- let r = (match at with
- | HDyn ->
- (* call getDyn() *)
- let r = alloc_tmp ctx HDyn in
- op ctx (OCallMethod (r,0,[ra;ridx]));
- let r = f r in
- (* call setDyn() *)
- op ctx (OCallMethod (alloc_tmp ctx HVoid,1,[ra;ridx;r]));
- r
- | _ ->
- (* bounds check against length *)
- let len = alloc_tmp ctx HI32 in
- op ctx (OField (len,ra,0)); (* length *)
- let j = jump ctx (fun i -> OJULt (ridx,len,i)) in
- op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx (array_class ctx at).cl_path "__expand", ra, ridx));
- j();
- match at with
- | HUI8 | HUI16 | HI32 | HF32 | HF64 | HI64->
- let hbytes = alloc_tmp ctx HBytes in
- op ctx (OField (hbytes, ra, 1));
- let ridx = shl ctx ridx (type_size_bits at) in
- hold ctx ridx;
- hold ctx hbytes;
- let r = alloc_tmp ctx at in
- read_mem ctx r hbytes ridx at;
- let r = f r in
- write_mem ctx hbytes ridx at r;
- free ctx ridx;
- free ctx hbytes;
- r
- | _ ->
- let arr = alloc_tmp ctx (HArray vt) in
- op ctx (OField (arr,ra,1));
- let r = alloc_tmp ctx at in
- op ctx (OGetArray (r,arr,ridx));
- hold ctx arr;
- let r = f r in
- free ctx arr;
- op ctx (OSetArray (arr,ridx,r));
- r
- ) in
- free ctx ra;
- free ctx ridx;
- r
- | ADynamic (eobj, fid) ->
- let robj = eval_null_check ctx eobj in
- hold ctx robj;
- let t = real_type ctx e1 in
- let r = alloc_tmp ctx t in
- op ctx (ODynGet (r,robj,fid));
- let r = cast_to ctx r (to_type ctx e1.etype) e1.epos in
- let r = f r in
- let r = cast_to ctx r t e1.epos in
- free ctx robj;
- op ctx (ODynSet (robj,fid,r));
- r
- | ANone | ALocal _ | AStaticFun _ | AInstanceFun _ | AInstanceProto _ | AVirtualMethod _ | AEnum _ | ACArray _ ->
- die "" __LOC__
- and build_capture_vars ctx f =
- let ignored_vars = ref PMap.empty in
- let used_vars = ref PMap.empty in
- (* get all captured vars in scope, ignore vars that are declared *)
- let decl_var v =
- if has_var_flag v VCaptured then ignored_vars := PMap.add v.v_id () !ignored_vars
- in
- let use_var v =
- if has_var_flag v VCaptured then used_vars := PMap.add v.v_id v !used_vars
- in
- let rec loop e =
- (match e.eexpr with
- | TLocal v ->
- use_var v;
- | TVar (v,_) ->
- decl_var v
- | TTry (_,catches) ->
- List.iter (fun (v,_) -> decl_var v) catches
- | TFunction f ->
- List.iter (fun (v,_) -> decl_var v) f.tf_args;
- | _ ->
- ()
- );
- Type.iter loop e
- in
- List.iter (fun (v,_) -> decl_var v) f.tf_args;
- loop f.tf_expr;
- 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
- Array.sort (fun v1 v2 -> v1.v_id - v2.v_id) cvars;
- let indexes = ref PMap.empty in
- let v0t = (if Array.length cvars = 1 then to_type ctx cvars.(0).v_type else HDyn) in
- let ct, group = (match Array.length cvars with
- | 0 -> HVoid, false
- | 1 when is_nullable v0t -> v0t, false
- | _ ->
- Array.iteri (fun i v -> indexes := PMap.add v.v_id i !indexes) cvars;
- let ctypes = Array.map (fun v -> to_type ctx v.v_type) cvars in
- let ct = tuple_type ctx (Array.to_list ctypes) in
- ct, true
- ) in
- {
- c_map = !indexes;
- c_vars = cvars;
- c_type = ct;
- c_group = group;
- }
- and gen_method_wrapper ctx rt t p =
- try
- PMap.find (rt,t) ctx.method_wrappers
- with Not_found ->
- let fid = lookup_alloc ctx.cfids () in
- ctx.method_wrappers <- PMap.add (rt,t) fid ctx.method_wrappers;
- let old = ctx.m in
- let targs, tret = (match t with HFun (args, ret) -> args, ret | _ -> die "" __LOC__) in
- let iargs, iret = (match rt with HFun (args, ret) -> args, ret | _ -> die "" __LOC__) in
- ctx.m <- method_context fid HDyn null_capture false;
- let rfun = alloc_tmp ctx rt in
- let rargs = List.map (fun t ->
- let r = alloc_tmp ctx t in
- hold ctx r;
- r
- ) targs in
- 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
- List.iter (free ctx) casts;
- let rret = alloc_tmp ctx iret in
- op ctx (OCallClosure (rret,rfun,casts));
- op ctx (ORet (cast_to ctx rret tret p));
- let f = {
- fpath = "","";
- findex = fid;
- ftype = HFun (rt :: targs, tret);
- regs = DynArray.to_array ctx.m.mregs.arr;
- code = DynArray.to_array ctx.m.mops;
- debug = make_debug ctx ctx.m.mdebug;
- assigns = Array.of_list (List.rev ctx.m.massign);
- } in
- ctx.m <- old;
- DynArray.add ctx.cfunctions f;
- fid
- and make_fun ?gen_content ctx name fidx f cthis cparent =
- let old = ctx.m in
- let capt = build_capture_vars ctx f in
- let has_captured_vars = Array.length capt.c_vars > 0 in
- let capt, use_parent_capture = (match cparent with
- | 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
- | _ -> capt, false
- ) in
- ctx.m <- method_context fidx (to_type ctx f.tf_type) capt (cthis <> None);
- set_curpos ctx f.tf_expr.epos;
- let tthis = (match cthis with
- | None -> None
- | Some c ->
- let t = to_type ctx (TInst (c,[])) in
- hold ctx (alloc_tmp ctx t); (* index 0 *)
- Some t
- ) in
- let rcapt = match has_captured_vars && cparent <> None with
- | true when capt.c_group ->
- let r = alloc_tmp ctx capt.c_type in
- hold ctx r;
- Some r
- | true ->
- Some (alloc_var ctx capt.c_vars.(0) true)
- | false ->
- None
- in
- let args = List.map (fun (v,o) ->
- let t = to_type ctx v.v_type in
- 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
- add_assign ~force:true ctx v; (* record var name *)
- rtype ctx r
- ) f.tf_args in
- if has_captured_vars then ctx.m.mcaptreg <- (match rcapt with
- | None when not capt.c_group ->
- -1
- | None ->
- let r = alloc_tmp ctx capt.c_type in
- hold ctx r;
- op ctx (OEnumAlloc (r,0));
- add_capture ctx r;
- r
- | Some r ->
- add_capture ctx r;
- r
- );
- List.iter (fun (v, o) ->
- let r = alloc_var ctx v false in
- let vt = to_type ctx v.v_type in
- let capt = captured_index ctx v in
- (match o with
- | None | Some {eexpr = TConst TNull} -> ()
- | Some c when not (is_nullable vt) ->
- (* if optional but not null, turn into a not nullable here *)
- let j = jump ctx (fun n -> OJNotNull (r,n)) in
- let t = alloc_tmp ctx vt in
- (match vt with
- | HUI8 | HUI16 | HI32 | HI64 ->
- (match c.eexpr with
- | TConst (TInt i) -> op ctx (OInt (t,alloc_i32 ctx i))
- | TConst (TFloat s) -> op ctx (OInt (t,alloc_i32 ctx (Int32.of_float (float_of_string s))))
- | _ -> die "" __LOC__)
- | HF32 | HF64 ->
- (match c.eexpr with
- | TConst (TInt i) -> op ctx (OFloat (t,alloc_float ctx (Int32.to_float i)))
- | TConst (TFloat s) -> op ctx (OFloat (t,alloc_float ctx (float_of_string s)))
- | _ -> die "" __LOC__)
- | HBool ->
- (match c.eexpr with
- | TConst (TBool b) -> op ctx (OBool (t,b))
- | _ -> die "" __LOC__)
- | _ ->
- die "" __LOC__);
- if capt = None then add_assign ctx v;
- let jend = jump ctx (fun n -> OJAlways n) in
- j();
- op ctx (OUnref (t,r));
- if capt = None then add_assign ctx v;
- jend();
- Hashtbl.replace ctx.m.mvars v.v_id t;
- free ctx r;
- hold ctx t
- | Some c ->
- let j = jump ctx (fun n -> OJNotNull (r,n)) in
- (match c.eexpr with
- | TConst (TNull | TThis | TSuper) -> die "" __LOC__
- | TConst (TInt i) when (match to_type ctx (Abstract.follow_with_abstracts v.v_type) with HUI8 | HUI16 | HI32 | HI64 | HDyn -> true | _ -> false) ->
- let tmp = alloc_tmp ctx HI32 in
- op ctx (OInt (tmp, alloc_i32 ctx i));
- op ctx (OToDyn (r, tmp));
- | TConst (TFloat s) when (match to_type ctx (Abstract.follow_with_abstracts v.v_type) with HUI8 | HUI16 | HI32 | HI64 -> true | _ -> false) ->
- let tmp = alloc_tmp ctx HI32 in
- op ctx (OInt (tmp, alloc_i32 ctx (Int32.of_float (float_of_string s))));
- op ctx (OToDyn (r, tmp));
- | TConst (TInt i) ->
- let tmp = alloc_tmp ctx HF64 in
- op ctx (OFloat (tmp, alloc_float ctx (Int32.to_float i)));
- op ctx (OToDyn (r, tmp));
- | TConst (TFloat s) ->
- let tmp = alloc_tmp ctx HF64 in
- op ctx (OFloat (tmp, alloc_float ctx (float_of_string s)));
- op ctx (OToDyn (r, tmp));
- | TConst (TBool b) ->
- let tmp = alloc_tmp ctx HBool in
- op ctx (OBool (tmp, b));
- op ctx (OToDyn (r, tmp));
- | TConst (TString s) ->
- op ctx (OMov (r, make_string ctx s f.tf_expr.epos))
- | _ ->
- op ctx (OMov (r, eval_to ctx c vt))
- );
- j();
- );
- (match capt with
- | None -> ()
- | Some index ->
- op ctx (OSetEnumField (ctx.m.mcaptreg, index, alloc_var ctx v false)));
- ) f.tf_args;
- (match gen_content with
- | None -> ()
- | Some f -> f());
- ignore(eval_expr ctx f.tf_expr);
- let tret = to_type ctx f.tf_type in
- let rec has_final_jump e =
- (* prevents a jump outside function bounds error *)
- match e.eexpr with
- | TBlock el -> (match List.rev el with e :: _ -> has_final_jump e | [] -> false)
- | TParenthesis e -> has_final_jump e
- | TReturn _ -> false
- | _ -> true
- in
- set_curpos ctx (max_pos f.tf_expr);
- if tret = HVoid then
- op ctx (ORet (alloc_tmp ctx HVoid))
- else if has_final_jump f.tf_expr then begin
- let r = alloc_tmp ctx tret in
- (match tret with
- | HI32 | HUI8 | HUI16 | HI64 -> op ctx (OInt (r,alloc_i32 ctx 0l))
- | HF32 | HF64 -> op ctx (OFloat (r,alloc_float ctx 0.))
- | HBool -> op ctx (OBool (r,false))
- | _ -> op ctx (ONull r));
- op ctx (ORet r)
- end;
- let fargs = (match tthis with None -> [] | Some t -> [t]) @ (match rcapt with None -> [] | Some r -> [rtype ctx r]) @ args in
- let hlf = {
- fpath = name;
- findex = fidx;
- ftype = HFun (fargs, tret);
- regs = DynArray.to_array ctx.m.mregs.arr;
- code = DynArray.to_array ctx.m.mops;
- debug = make_debug ctx ctx.m.mdebug;
- assigns = Array.of_list (List.rev ctx.m.massign);
- } in
- ctx.m <- old;
- Hashtbl.add ctx.defined_funs fidx ();
- let f = if ctx.optimize && (gen_content = None || name <> ("","")) then begin
- let t = Timer.timer ["generate";"hl";"opt"] in
- let f = Hlopt.optimize ctx.dump_out (DynArray.get ctx.cstrings.arr) hlf f in
- t();
- f
- end else
- hlf
- in
- DynArray.add ctx.cfunctions f;
- capt
- let generate_static ctx c f =
- match f.cf_kind with
- | Var _ ->
- ()
- | Method _ when has_class_field_flag f CfExtern ->
- ()
- | Method m ->
- let add_native lib name =
- let fid = alloc_fid ctx c f in
- ignore(lookup ctx.cnatives (name ^ "@" ^ lib,fid) (fun() ->
- Hashtbl.add ctx.defined_funs fid ();
- (alloc_string ctx lib, alloc_string ctx name,to_type ctx f.cf_type,fid)
- ));
- in
- let rec loop = function
- | (Meta.HlNative,[(EConst(String(lib,_)),_);(EConst(String(name,_)),_)] ,_ ) :: _ ->
- add_native lib name
- | (Meta.HlNative,[(EConst(String(lib,_)),_)] ,_ ) :: _ ->
- add_native lib f.cf_name
- | (Meta.HlNative,[(EConst(Float(ver,_)),_)] ,_ ) :: _ ->
- let cur_ver = (try Common.defined_value ctx.com Define.HlVer with Not_found -> "") in
- if cur_ver < ver then
- let gen_content() =
- op ctx (OThrow (make_string ctx ("Requires compiling with -D hl-ver=" ^ ver ^ ".0 or higher") null_pos));
- in
- (match f.cf_expr with
- | Some { eexpr = TFunction fn } -> ignore(make_fun ctx ~gen_content (s_type_path c.cl_path,f.cf_name) (alloc_fid ctx c f) fn None None)
- | _ -> if not (Meta.has Meta.NoExpr f.cf_meta) then abort "Missing function body" f.cf_pos)
- else
- add_native "std" f.cf_name
- | (Meta.HlNative,[] ,_ ) :: _ ->
- add_native "std" f.cf_name
- | (Meta.HlNative,_ ,p) :: _ ->
- abort "Invalid @:hlNative decl" p
- | [] ->
- (match f.cf_expr with
- | Some { eexpr = TFunction fn } -> ignore(make_fun ctx (s_type_path c.cl_path,f.cf_name) (alloc_fid ctx c f) fn None None)
- | _ -> if not (Meta.has Meta.NoExpr f.cf_meta) then abort "Missing function body" f.cf_pos)
- | _ :: l ->
- loop l
- in
- loop f.cf_meta
- let generate_member ctx c f =
- match f.cf_kind with
- | Var _ -> ()
- | _ when is_extern_field f -> ()
- | Method m ->
- let gen_content = if f.cf_name <> "new" then None else Some (fun() ->
- let o = (match class_type ctx c (extract_param_types c.cl_params) false with
- | HObj o | HStruct o -> o
- | _ -> die "" __LOC__
- ) in
- (*
- init dynamic functions
- *)
- List.iter (fun f ->
- match f.cf_kind with
- | Method MethDynamic ->
- let r = alloc_tmp ctx (to_type ctx f.cf_type) in
- let fid = (try fst (get_index f.cf_name o) with Not_found -> die "" __LOC__) in
- op ctx (OGetThis (r,fid));
- op ctx (OJNotNull (r,2));
- op ctx (OInstanceClosure (r,alloc_fid ctx c f,0));
- op ctx (OSetThis (fid,r));
- | _ -> ()
- ) c.cl_ordered_fields;
- ) in
- let ff = match f.cf_expr with
- | Some { eexpr = TFunction f } -> f
- | None when has_class_field_flag f CfAbstract ->
- let tl,tr = match follow f.cf_type with
- | TFun(tl,tr) -> tl,tr
- | _ -> die "" __LOC__
- in
- let args = List.map (fun (n,_,t) ->
- let v = Type.alloc_var VGenerated n t null_pos in
- (v,None)
- ) tl in
- {
- tf_args = args;
- tf_type = tr;
- tf_expr = mk (TThrow (mk (TConst TNull) t_dynamic null_pos)) t_dynamic null_pos;
- }
- | _ -> abort "Missing function body" f.cf_pos
- in
- ignore(make_fun ?gen_content ctx (s_type_path c.cl_path,f.cf_name) (alloc_fid ctx c f) ff (Some c) None);
- 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
- let p = f.cf_pos in
- (* function __string() return this.toString().bytes *)
- let ethis = mk (TConst TThis) (TInst (c,extract_param_types c.cl_params)) p in
- 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
- 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
- let estr = mk (TReturn (Some (mk (TField (tstr,FInstance (cstr,[],cf_bytes))) cf_bytes.cf_type p))) ctx.com.basic.tvoid p in
- 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)
- end
- let generate_type ctx t =
- match t with
- | TClassDecl c when (has_class_flag c CInterface) ->
- ()
- | TClassDecl c when (has_class_flag c CExtern) ->
- List.iter (fun f ->
- List.iter (fun (name,args,pos) ->
- match name with
- | Meta.HlNative -> generate_static ctx c f
- | _ -> ()
- ) f.cf_meta
- ) c.cl_ordered_statics
- | TClassDecl c ->
- List.iter (generate_static ctx c) c.cl_ordered_statics;
- (match c.cl_constructor with
- | None -> ()
- | Some f ->
- let merge_inits e =
- match e with
- | Some ({ eexpr = TFunction ({ tf_expr = { eexpr = TBlock el } as ef } as f) } as e) ->
- let merge ei =
- let rec loop ei =
- let ei = Type.map_expr loop ei in
- { ei with epos = e.epos }
- in
- if ei.epos.pmin < e.epos.pmin || ei.epos.pmax > e.epos.pmax then loop ei else ei
- in
- Some { e with eexpr = TFunction({ f with tf_expr = { ef with eexpr = TBlock (List.map merge el) }}) }
- | _ ->
- e
- in
- generate_member ctx c { f with cf_expr = merge_inits f.cf_expr });
- List.iter (generate_member ctx c) c.cl_ordered_fields;
- | TEnumDecl _ | TTypeDecl _ | TAbstractDecl _ ->
- ()
- let generate_static_init ctx types main =
- let exprs = ref [] in
- let t_void = ctx.com.basic.tvoid in
- let gen_content() =
- let is_init = alloc_tmp ctx HBool in
- op ctx (OCall0 (is_init, alloc_fun_path ctx ([],"Type") "init"));
- hold ctx is_init;
- (* init class values *)
- List.iter (fun t ->
- match t with
- | 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 ->
- let path = if c == ctx.array_impl.abase then [],"Array" else if c == ctx.base_class then [],"Class" else c.cl_path in
- let g, ct = class_global ~resolve:false ctx c in
- let ctype = if c == ctx.array_impl.abase then ctx.array_impl.aall else c in
- let t = class_type ctx ctype (extract_param_types ctype.cl_params) false in
- let index name =
- match ct with
- | HObj o ->
- fst (try get_index name o with Not_found -> die "" __LOC__)
- | _ ->
- die "" __LOC__
- in
- let rc = (match t with
- | HObj o when (match o.pclassglobal with None -> -1 | Some i -> i) <> g ->
- (* manual registration for objects with prototype tricks (Array) *)
- let rc = alloc_tmp ctx ct in
- op ctx (ONew rc);
- op ctx (OSetGlobal (g,rc));
- hold ctx rc;
- let rt = alloc_tmp ctx HType in
- op ctx (OType (rt, t));
- op ctx (OSetField (rc,index "__type__",rt));
- 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 }));
- let rname = alloc_tmp ctx HBytes in
- op ctx (OString (rname, alloc_string ctx (s_type_path path)));
- op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx ([],"Type") "register",rname,rc));
- rc
- | _ ->
- let rct = alloc_tmp ctx HType in
- op ctx (OType (rct, ct));
- hold ctx rct;
- let rt = alloc_tmp ctx HType in
- op ctx (OType (rt, t));
- let rname = alloc_tmp ctx HBytes in
- op ctx (OString (rname, alloc_string ctx (s_type_path path)));
- let rc = alloc_tmp ctx (class_type ctx ctx.base_class [] false) in
- op ctx (OCall3 (rc, alloc_fun_path ctx ([],"Type") "initClass", rct, rt, rname));
- hold ctx rc;
- free ctx rct;
- rc
- ) in
- let gather_implements() =
- let classes = ref [] in
- let rec lookup cv =
- List.exists (fun (i,_) -> i == c || lookup i) cv.cl_implements
- in
- let check = function
- | TClassDecl c when (has_class_flag c CInterface) = false && not (has_class_flag c CExtern) -> if lookup c then classes := c :: !classes
- | _ -> ()
- in
- List.iter check ctx.com.types;
- !classes
- in
- if (has_class_flag c CInterface) then begin
- let l = gather_implements() in
- let rt = alloc_tmp ctx HType in
- op ctx (OType (rt, HType));
- let ra = alloc_array ctx (reg_int ctx (List.length l)) HType in
- list_iteri (fun i intf ->
- op ctx (OType (rt, to_type ctx (TInst (intf,[]))));
- op ctx (OSetArray (ra, reg_int ctx i, rt));
- ) l;
- op ctx (OSetField (rc,index "__implementedBy__",ra));
- (* TODO : use a plain class for interface object since we don't allow statics *)
- let rt = alloc_tmp ctx ct in
- op ctx (OSafeCast (rt, rc));
- op ctx (OSetGlobal (g, rt));
- end;
- (match Texpr.build_metadata ctx.com.basic (TClassDecl c) with
- | None -> ()
- | Some e ->
- let r = eval_to ctx e HDyn in
- op ctx (OSetField (rc,index "__meta__",r)));
- free ctx rc;
- | TEnumDecl e when not (has_enum_flag e EnExtern) ->
- let et = enum_class ctx e in
- let t = enum_type ctx e in
- let ret = alloc_tmp ctx HType in
- op ctx (OType (ret, et));
- hold ctx ret;
- let rt = alloc_tmp ctx HType in
- op ctx (OType (rt, t));
- let r = alloc_tmp ctx (class_type ctx ctx.base_enum [] false) in
- op ctx (OCall2 (r, alloc_fun_path ctx ([],"Type") "initEnum", ret, rt));
- free ctx ret;
- let index name =
- match et with
- | HObj o ->
- fst (try get_index name o with Not_found -> die "" __LOC__)
- | _ ->
- die "" __LOC__
- in
- let avalues = alloc_tmp ctx (HArray t) in
- op ctx (OField (avalues, r, index "__evalues__"));
- List.iter (fun n ->
- let f = PMap.find n e.e_constrs in
- match follow f.ef_type with
- | TFun _ -> ()
- | _ ->
- let g = alloc_global ctx (efield_name e f) t in
- let r = alloc_tmp ctx t in
- let rd = alloc_tmp ctx HDyn in
- op ctx (OGetArray (rd,avalues, reg_int ctx f.ef_index));
- op ctx (OSafeCast (r, rd));
- op ctx (OSetGlobal (g,r));
- ) e.e_names;
- (match Texpr.build_metadata ctx.com.basic (TEnumDecl e) with
- | None -> ()
- | Some e -> op ctx (OSetField (r,index "__meta__",eval_to ctx e HDyn)));
- | TAbstractDecl { a_path = [], name; a_pos = pos } ->
- (match name with
- | "Int" | "Float" | "Dynamic" | "Bool" ->
- let is_bool = name = "Bool" in
- let t = class_type ctx (if is_bool then ctx.core_enum else ctx.core_type) [] false in
- let index name =
- match t with
- | HObj o ->
- fst (try get_index name o with Not_found -> die "" __LOC__)
- | _ ->
- die "" __LOC__
- in
- let g = alloc_global ctx ("$" ^ name) t in
- let r = alloc_tmp ctx t in
- let rt = alloc_tmp ctx HType in
- op ctx (ONew r);
- op ctx (OType (rt,(match name with "Int" -> HI32 | "Float" -> HF64 | "Dynamic" -> HDyn | "Bool" -> HBool | _ -> die "" __LOC__)));
- op ctx (OSetField (r,index "__type__",rt));
- op ctx (OSetField (r,index (if is_bool then "__ename__" else "__name__"),make_string ctx name pos));
- op ctx (OSetGlobal (g,r));
- let bytes = alloc_tmp ctx HBytes in
- op ctx (OString (bytes, alloc_string ctx name));
- op ctx (OCall2 (alloc_tmp ctx HVoid, alloc_fun_path ctx ([],"Type") "register",bytes,r));
- | _ ->
- ())
- | _ ->
- ()
- ) types;
- let j = jump ctx (fun d -> OJTrue (is_init,d)) in
- op ctx (ORet (alloc_tmp ctx HVoid));
- j();
- free ctx is_init;
- in
- (* init class statics *)
- let init_exprs = ref [] in
- List.iter (fun t ->
- (match t with TClassDecl { cl_init = Some {cf_expr = Some e} } -> init_exprs := e :: !init_exprs | _ -> ());
- match t with
- | TClassDecl c when not (has_class_flag c CExtern) ->
- List.iter (fun f ->
- match f.cf_kind, f.cf_expr with
- | Var _, Some e ->
- let p = e.epos in
- 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
- exprs := e :: !exprs;
- | _ ->
- ()
- ) c.cl_ordered_statics;
- | _ -> ()
- ) types;
- (* call main() *)
- (match main with
- | None -> ()
- | Some e -> exprs := e :: !exprs);
- let fid = lookup_alloc ctx.cfids () in
- let exprs = List.rev !init_exprs @ List.rev !exprs in
- ignore(make_fun ~gen_content ctx ("","") fid { tf_expr = mk (TBlock exprs) t_void null_pos; tf_args = []; tf_type = t_void } None None);
- fid
- (* --------------------------------------------------------------------------------------------------------------------- *)
- (* WRITE *)
- (* from -500M to +500M
- 0[7] = 0-127
- 10[+/-][5] [8] = -x2000/+x2000
- 11[+/-][5] [24] = -x20000000/+x20000000
- *)
- let write_index_gen b i =
- if i < 0 then
- let i = -i in
- if i < 0x2000 then begin
- b ((i lsr 8) lor 0xA0);
- b (i land 0xFF);
- end else if i >= 0x20000000 then die "" __LOC__ else begin
- b ((i lsr 24) lor 0xE0);
- b ((i lsr 16) land 0xFF);
- b ((i lsr 8) land 0xFF);
- b (i land 0xFF);
- end
- else if i < 0x80 then
- b i
- else if i < 0x2000 then begin
- b ((i lsr 8) lor 0x80);
- b (i land 0xFF);
- end else if i >= 0x20000000 then die "" __LOC__ else begin
- b ((i lsr 24) lor 0xC0);
- b ((i lsr 16) land 0xFF);
- b ((i lsr 8) land 0xFF);
- b (i land 0xFF);
- end
- let write_code ch code debug =
- let all_types, htypes = gather_types code in
- let byte = IO.write_byte ch in
- let write_index = write_index_gen byte in
- let write_type t =
- write_index (try PMap.find t htypes with Not_found -> die (tstr t) __LOC__)
- in
- let write_op op =
- let o = Obj.repr op in
- let oid = Obj.tag o in
- match op with
- | OLabel _ | ONop _ | OAssert _ ->
- byte oid
- | OCall2 (r,g,a,b) ->
- byte oid;
- write_index r;
- write_index g;
- write_index a;
- write_index b;
- | OCall3 (r,g,a,b,c) ->
- byte oid;
- write_index r;
- write_index g;
- write_index a;
- write_index b;
- write_index c;
- | OCall4 (r,g,a,b,c,d) ->
- byte oid;
- write_index r;
- write_index g;
- write_index a;
- write_index b;
- write_index c;
- write_index d;
- | OCallN (r,f,rl) | OCallClosure (r,f,rl) | OCallMethod (r,f,rl) | OCallThis (r,f,rl) | OMakeEnum (r,f,rl) ->
- byte oid;
- write_index r;
- write_index f;
- let n = List.length rl in
- if n > 0xFF then die "" __LOC__;
- byte n;
- List.iter write_index rl
- | OType (r,t) ->
- byte oid;
- write_index r;
- write_type t
- | OSwitch (r,pl,eend) ->
- byte oid;
- write_index r;
- write_index (Array.length pl);
- Array.iter write_index pl;
- write_index eend
- | OEnumField (r,e,i,idx) ->
- byte oid;
- write_index r;
- write_index e;
- write_index i;
- write_index idx;
- | _ ->
- let field n = (Obj.magic (Obj.field o n) : int) in
- match Obj.size o with
- | 1 ->
- let a = field 0 in
- byte oid;
- write_index a;
- | 2 ->
- let a = field 0 in
- let b = field 1 in
- byte oid;
- write_index a;
- write_index b;
- | 3 ->
- let a = field 0 in
- let b = field 1 in
- let c = field 2 in
- byte oid;
- write_index a;
- write_index b;
- write_index c;
- | _ ->
- die "" __LOC__
- in
- IO.nwrite_string ch "HLB";
- byte code.version;
- let flags = ref 0 in
- if debug then flags := !flags lor 1;
- byte !flags;
- write_index (Array.length code.ints);
- write_index (Array.length code.floats);
- write_index (Array.length code.strings);
- if code.version >= 5 then write_index (Array.length code.bytes);
- write_index (Array.length all_types);
- write_index (Array.length code.globals);
- write_index (Array.length code.natives);
- write_index (Array.length code.functions);
- write_index (Array.length code.constants);
- write_index code.entrypoint;
- Array.iter (IO.write_real_i32 ch) code.ints;
- Array.iter (IO.write_double ch) code.floats;
- let write_strings strings =
- let str_length = ref 0 in
- Array.iter (fun str -> str_length := !str_length + String.length str + 1) strings;
- IO.write_i32 ch !str_length;
- Array.iter (IO.write_string ch) strings;
- Array.iter (fun str -> write_index (String.length str)) strings;
- in
- write_strings code.strings;
- let write_bytes bytes =
- let bytes_length = ref 0 in
- Array.iter (fun b -> bytes_length := !bytes_length + Bytes.length b) bytes;
- IO.write_i32 ch !bytes_length;
- Array.iter (IO.nwrite ch) bytes;
- let bytes_pos = ref 0 in
- Array.iter (fun b ->
- write_index (!bytes_pos);
- bytes_pos := !bytes_pos + Bytes.length b
- ) bytes;
- in
- if code.version >= 5 then write_bytes code.bytes;
- if debug then begin
- write_index (Array.length code.debugfiles);
- write_strings code.debugfiles;
- end;
- Array.iter (fun t ->
- match t with
- | HVoid -> byte 0
- | HUI8 -> byte 1
- | HUI16 -> byte 2
- | HI32 -> byte 3
- | HI64 -> byte 4
- | HF32 -> byte 5
- | HF64 -> byte 6
- | HBool -> byte 7
- | HBytes -> byte 8
- | HDyn -> byte 9
- | HFun (args,ret) | HMethod (args,ret) ->
- let n = List.length args in
- if n > 0xFF then die "" __LOC__;
- byte (match t with HFun _ -> 10 | _ -> 20);
- byte n;
- List.iter write_type args;
- write_type ret
- | HObj p | HStruct p ->
- byte (if is_struct t then 21 else 11);
- write_index p.pid;
- (match p.psuper with
- | None -> write_index (-1)
- | Some tsup -> write_type (match t with HObj _ -> HObj tsup | _ -> HStruct tsup));
- (match p.pclassglobal with
- | None -> write_index 0
- | Some g -> write_index (g + 1));
- write_index (Array.length p.pfields);
- write_index (Array.length p.pproto);
- write_index (List.length p.pbindings);
- Array.iter (fun (_,n,t) -> write_index n; write_type t) p.pfields;
- 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;
- List.iter (fun (fid,fidx) -> write_index fid; write_index fidx) p.pbindings;
- | HArray _ ->
- byte 12
- | HType ->
- byte 13
- | HRef t ->
- byte 14;
- write_type t
- | HVirtual v ->
- byte 15;
- write_index (Array.length v.vfields);
- Array.iter (fun (_,sid,t) -> write_index sid; write_type t) v.vfields
- | HDynObj ->
- byte 16
- | HAbstract (_,i) ->
- byte 17;
- write_index i
- | HEnum e ->
- byte 18;
- write_index e.eid;
- (match e.eglobal with
- | None -> write_index 0
- | Some g -> write_index (g + 1));
- write_index (Array.length e.efields);
- Array.iter (fun (_,nid,tl) ->
- write_index nid;
- if Array.length tl > 0xFF then die "" __LOC__;
- byte (Array.length tl);
- Array.iter write_type tl;
- ) e.efields
- | HNull t ->
- byte 19;
- write_type t
- | HPacked t ->
- byte 22;
- write_type t
- ) all_types;
- let write_debug_infos debug =
- let curfile = ref (-1) in
- let curpos = ref 0 in
- let rcount = ref 0 in
- let rec flush_repeat p =
- if !rcount > 0 then begin
- if !rcount > 15 then begin
- byte ((15 lsl 2) lor 2);
- rcount := !rcount - 15;
- flush_repeat(p)
- end else begin
- let delta = p - !curpos in
- let delta = (if delta > 0 && delta < 4 then delta else 0) in
- byte ((delta lsl 6) lor (!rcount lsl 2) lor 2);
- rcount := 0;
- curpos := !curpos + delta;
- end
- end
- in
- Array.iter (fun (f,p,_) ->
- if f <> !curfile then begin
- flush_repeat(p);
- curfile := f;
- byte ((f lsr 7) lor 1);
- byte (f land 0xFF);
- end;
- if p <> !curpos then flush_repeat(p);
- if p = !curpos then
- rcount := !rcount + 1
- else
- let delta = p - !curpos in
- if delta > 0 && delta < 32 then
- byte ((delta lsl 3) lor 4)
- else begin
- byte (p lsl 3);
- byte (p lsr 5);
- byte (p lsr 13);
- end;
- curpos := p;
- ) debug;
- flush_repeat(!curpos)
- in
- Array.iter write_type code.globals;
- Array.iter (fun (lib_index, name_index,ttype,findex) ->
- write_index lib_index;
- write_index name_index;
- write_type ttype;
- write_index findex;
- ) code.natives;
- Array.iter (fun f ->
- write_type f.ftype;
- write_index f.findex;
- write_index (Array.length f.regs);
- write_index (Array.length f.code);
- Array.iter write_type f.regs;
- Array.iter write_op f.code;
- if debug then begin
- write_debug_infos f.debug;
- write_index (Array.length f.assigns);
- Array.iter (fun (i,p) ->
- write_index i;
- write_index (p + 1);
- ) f.assigns;
- end;
- ) code.functions;
- Array.iter (fun (g,fields) ->
- write_index g;
- write_index (Array.length fields);
- Array.iter write_index fields;
- ) code.constants
- (* --------------------------------------------------------------------------------------------------------------------- *)
- let create_context com dump =
- let get_type name =
- try
- List.find (fun t -> (t_infos t).mt_path = (["hl"],name)) com.types
- with Not_found -> try
- List.find (fun t -> (t_infos t).mt_path = (["hl";"types"],name)) com.types
- with Not_found ->
- failwith ("hl type " ^ name ^ " not found")
- in
- let get_class name =
- match get_type name with
- | TClassDecl c -> c
- | _ -> die "" __LOC__
- in
- let get_abstract name =
- match get_type name with
- | TAbstractDecl a -> a
- | _ -> die "" __LOC__
- in
- let ctx = {
- com = com;
- optimize = not (Common.raw_defined com "hl_no_opt");
- w_null_compare = Common.raw_defined com "hl_w_null_compare";
- dump_out = if dump then Some (IO.output_channel (open_out_bin "dump/hlopt.txt")) else None;
- m = method_context 0 HVoid null_capture false;
- cints = new_lookup();
- cstrings = new_lookup();
- cbytes = new_lookup();
- cfloats = new_lookup();
- cglobals = new_lookup();
- cnatives = new_lookup();
- cconstants = new_lookup();
- cfunctions = DynArray.create();
- overrides = Hashtbl.create 0;
- cached_types = PMap.empty;
- cached_tuples = PMap.empty;
- cfids = new_lookup();
- defined_funs = Hashtbl.create 0;
- tstring = HVoid;
- array_impl = {
- aall = get_class "ArrayAccess";
- abase = get_class "ArrayBase";
- adyn = get_class "ArrayDyn";
- aobj = get_class "ArrayObj";
- aui16 = get_class "ArrayBytes_hl_UI16";
- ai32 = get_class "ArrayBytes_Int";
- af32 = get_class "ArrayBytes_hl_F32";
- af64 = get_class "ArrayBytes_Float";
- ai64 = get_class "ArrayBytes_hl_I64";
- };
- base_class = get_class "Class";
- base_enum = get_class "Enum";
- base_type = get_class "BaseType";
- core_type = get_class "CoreType";
- core_enum = get_class "CoreEnum";
- ref_abstract = get_abstract "Ref";
- anons_cache = PMap.empty;
- rec_cache = [];
- method_wrappers = PMap.empty;
- cdebug_files = new_lookup();
- macro_typedefs = Hashtbl.create 0;
- ct_delayed = [];
- ct_depth = 0;
- } in
- ctx.tstring <- to_type ctx ctx.com.basic.tstring;
- ignore(alloc_string ctx "");
- ignore(class_type ctx ctx.base_class [] false);
- ctx
- let add_types ctx types =
- List.iter (fun t ->
- match t with
- | TClassDecl ({ cl_path = ["hl";"types"], ("BytesIterator"|"BytesKeyValueIterator"|"ArrayBytes") } as c) ->
- add_class_flag c CExtern
- | TClassDecl c ->
- let rec loop p f =
- match p with
- | Some (p,_) when PMap.mem f.cf_name p.cl_fields || loop p.cl_super f ->
- Hashtbl.replace ctx.overrides (f.cf_name,p.cl_path) true;
- true
- | _ ->
- false
- in
- List.iter (fun f -> if has_class_field_flag f CfOverride then ignore(loop c.cl_super f)) c.cl_ordered_fields;
- List.iter (fun (m,args,p) ->
- if m = Meta.HlNative then
- let lib, prefix = (match args with
- | [(EConst (String(lib,_)),_)] -> lib, ""
- | [(EConst (String(lib,_)),_);(EConst (String(p,_)),_)] -> lib, p
- | _ -> abort "hlNative on class requires library name" p
- ) in
- (* adds :hlNative for all empty methods *)
- List.iter (fun f ->
- match f.cf_kind with
- | Method MethNormal when not (List.exists (fun (m,_,_) -> m = Meta.HlNative) f.cf_meta) ->
- (match f.cf_expr with
- | Some { eexpr = TFunction { tf_expr = { eexpr = TBlock ([] | [{ eexpr = TReturn (Some { eexpr = TConst _ })}]) } } } | None ->
- let name = prefix ^ String.lowercase_ascii (Str.global_replace (Str.regexp "[A-Z]+") "_\\0" f.cf_name) in
- f.cf_meta <- (Meta.HlNative, [(EConst (String(lib,SDoubleQuotes)),p);(EConst (String(name,SDoubleQuotes)),p)], p) :: f.cf_meta;
- | _ -> ())
- | _ -> ()
- ) c.cl_ordered_statics
- ) c.cl_meta;
- | _ -> ()
- ) types;
- List.iter (generate_type ctx) types
- let build_code ctx types main =
- let ep = generate_static_init ctx types main in
- let bytes = DynArray.to_array ctx.cbytes.arr in
- {
- version = if Array.length bytes = 0 then 4 else 5;
- entrypoint = ep;
- strings = DynArray.to_array ctx.cstrings.arr;
- bytes = bytes;
- ints = DynArray.to_array ctx.cints.arr;
- floats = DynArray.to_array ctx.cfloats.arr;
- globals = DynArray.to_array ctx.cglobals.arr;
- natives = DynArray.to_array ctx.cnatives.arr;
- functions = DynArray.to_array ctx.cfunctions;
- debugfiles = DynArray.to_array ctx.cdebug_files.arr;
- constants = DynArray.to_array ctx.cconstants.arr;
- }
- let check ctx =
- PMap.iter (fun (s,p) fid ->
- if not (Hashtbl.mem ctx.defined_funs fid) then failwith (Printf.sprintf "Unresolved method %s:%s(@%d)" (s_type_path p) s fid)
- ) ctx.cfids.map
- let make_context_sign com =
- let mhash = Hashtbl.create 0 in
- List.iter (fun t ->
- let mt = t_infos t in
- let mid = mt.mt_module.m_id in
- Hashtbl.add mhash mid true
- ) com.types;
- let data = Marshal.to_string mhash [No_sharing] in
- Digest.to_hex (Digest.string data)
- let prev_sign = ref "" and prev_data = ref ""
- let generate com =
- let dump = Common.defined com Define.Dump in
- let hl_check = Common.raw_defined com "hl_check" in
- let sign = make_context_sign com in
- if sign = !prev_sign && not dump && not hl_check then begin
- (* reuse previously generated data *)
- let ch = open_out_bin com.file in
- output_string ch !prev_data;
- close_out ch;
- end else
- let ctx = create_context com dump in
- add_types ctx com.types;
- let code = build_code ctx com.types com.main.main_expr in
- Array.sort (fun (lib1,_,_,_) (lib2,_,_,_) -> lib1 - lib2) code.natives;
- if dump then begin
- (match ctx.dump_out with None -> () | Some ch -> IO.close_out ch);
- let ch = open_out_bin "dump/hlcode.txt" in
- Hlcode.dump (fun s -> output_string ch (s ^ "\n")) code;
- close_out ch;
- end;
- (*if Common.raw_defined com "hl_dump_spec" then begin
- let ch = open_out_bin "dump/hlspec.txt" in
- let write s = output_string ch (s ^ "\n") in
- Array.iter (fun f ->
- write (fundecl_name f);
- let spec = Hlinterp.make_spec code f in
- List.iter (fun s -> write ("\t" ^ Hlinterp.spec_string s)) spec;
- write "";
- ) code.functions;
- close_out ch;
- end;*)
- if hl_check then begin
- check ctx;
- Hlinterp.check com.error code;
- end;
- let t = Timer.timer ["generate";"hl";"write"] in
- let escape_command s =
- let b = Buffer.create 0 in
- String.iter (fun ch -> if (ch=='"' || ch=='\\' ) then Buffer.add_string b "\\"; Buffer.add_char b ch) s;
- "\"" ^ Buffer.contents b ^ "\""
- in
- if Path.file_extension com.file = "c" then begin
- let gnames = Array.make (Array.length code.globals) "" in
- PMap.iter (fun n i -> gnames.(i) <- n) ctx.cglobals.map;
- if not (Common.defined com Define.SourceHeader) then begin
- let version_major = com.version / 1000 in
- let version_minor = (com.version mod 1000) / 100 in
- let version_revision = (com.version mod 100) in
- 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);
- end;
- Hl2c.write_c com com.file code gnames;
- let t = Timer.timer ["nativecompile";"hl"] in
- if not (Common.defined com Define.NoCompilation) && com.run_command_args "haxelib" ["run";"hashlink";"build";escape_command com.file] <> 0 then failwith "Build failed";
- t();
- end else begin
- let ch = IO.output_string() in
- write_code ch code (not (Common.raw_defined com "hl_no_debug"));
- let str = IO.close_out ch in
- let ch = open_out_bin com.file in
- output_string ch str;
- close_out ch;
- prev_sign := sign;
- prev_data := str;
- end;
- Hlopt.clean_cache();
- t();
- if Common.raw_defined com "run" then begin
- if com.run_command_args "haxelib" ["run";"hashlink";"run";escape_command com.file] <> 0 then failwith "Failed to run HL";
- end;
- if Common.defined com Define.Interp then
- try
- let t = Timer.timer ["generate";"hl";"interp"] in
- let ctx = Hlinterp.create true in
- Hlinterp.add_code ctx code;
- t();
- with
- Failure msg -> abort msg null_pos
|