2
0

optimizer.ml 59 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674
  1. (*
  2. * Copyright (C)2005-2013 Haxe Foundation
  3. *
  4. * Permission is hereby granted, free of charge, to any person obtaining a
  5. * copy of this software and associated documentation files (the "Software"),
  6. * to deal in the Software without restriction, including without limitation
  7. * the rights to use, copy, modify, merge, publish, distribute, sublicense,
  8. * and/or sell copies of the Software, and to permit persons to whom the
  9. * Software is furnished to do so, subject to the following conditions:
  10. *
  11. * The above copyright notice and this permission notice shall be included in
  12. * all copies or substantial portions of the Software.
  13. *
  14. * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  15. * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  16. * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  17. * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  18. * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  19. * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  20. * DEALINGS IN THE SOFTWARE.
  21. *)
  22. open Ast
  23. open Type
  24. open Common
  25. open Typecore
  26. (* ---------------------------------------------------------------------- *)
  27. (* API OPTIMIZATIONS *)
  28. (* tells if an expression causes side effects. This does not account for potential null accesses (fields/arrays/ops) *)
  29. let has_side_effect e =
  30. let rec loop e =
  31. match e.eexpr with
  32. | TConst _ | TLocal _ | TTypeExpr _ | TFunction _ -> ()
  33. | TCall ({ eexpr = TField(_,FStatic({ cl_path = ([],"Std") },{ cf_name = "string" })) },args) -> Type.iter loop e
  34. | TNew _ | TCall _ | TBinop ((OpAssignOp _ | OpAssign),_,_) | TUnop ((Increment|Decrement),_,_) -> raise Exit
  35. | TReturn _ | TBreak | TContinue | TThrow _ | TCast (_,Some _) -> raise Exit
  36. | TArray _ | TEnumParameter _ | TCast (_,None) | TBinop _ | TUnop _ | TParenthesis _ | TMeta _ | TWhile _ | TFor _
  37. | TField _ | TIf _ | TTry _ | TSwitch _ | TArrayDecl _ | TBlock _ | TObjectDecl _ | TVar _ -> Type.iter loop e
  38. in
  39. try
  40. loop e; false
  41. with Exit ->
  42. true
  43. let rec is_exhaustive e1 = match e1.eexpr with
  44. | TMeta((Meta.Exhaustive,_,_),_) -> true
  45. | TMeta(_, e1) | TParenthesis e1 -> is_exhaustive e1
  46. | _ -> false
  47. let mk_untyped_call name p params =
  48. {
  49. eexpr = TCall({ eexpr = TLocal(alloc_unbound_var name t_dynamic); etype = t_dynamic; epos = p }, params);
  50. etype = t_dynamic;
  51. epos = p;
  52. }
  53. let api_inline2 com c field params p =
  54. match c.cl_path, field, params with
  55. | ([],"Type"),"enumIndex",[{ eexpr = TField (_,FEnum (en,f)) }] -> (match com.platform with
  56. | Cs when en.e_extern && not (Meta.has Meta.HxGen en.e_meta) ->
  57. (* We don't want to optimize enums from external sources; as they might change unexpectedly *)
  58. (* and since native C# enums don't have the concept of index - they have rather a value, *)
  59. (* which can't be mapped to a native API - this kind of substitution is dangerous *)
  60. None
  61. | _ ->
  62. Some (mk (TConst (TInt (Int32.of_int f.ef_index))) com.basic.tint p))
  63. | ([],"Type"),"enumIndex",[{ eexpr = TCall({ eexpr = TField (_,FEnum (en,f)) },pl) }] when List.for_all (fun e -> not (has_side_effect e)) pl ->
  64. (match com.platform with
  65. | Cs when en.e_extern && not (Meta.has Meta.HxGen en.e_meta) ->
  66. (* see comment above *)
  67. None
  68. | _ ->
  69. Some (mk (TConst (TInt (Int32.of_int f.ef_index))) com.basic.tint p))
  70. | ([],"Std"),"int",[{ eexpr = TConst (TInt _) } as e] ->
  71. Some { e with epos = p }
  72. | ([],"String"),"fromCharCode",[{ eexpr = TConst (TInt i) }] when i > 0l && i < 128l ->
  73. Some (mk (TConst (TString (String.make 1 (char_of_int (Int32.to_int i))))) com.basic.tstring p)
  74. | ([],"Std"),"string",[{ eexpr = TConst c } as e] ->
  75. (match c with
  76. | TString s ->
  77. Some { e with epos = p }
  78. | TInt i ->
  79. Some { eexpr = TConst (TString (Int32.to_string i)); epos = p; etype = com.basic.tstring }
  80. | TBool b ->
  81. Some { eexpr = TConst (TString (if b then "true" else "false")); epos = p; etype = com.basic.tstring }
  82. | _ ->
  83. None)
  84. | ([],"Std"),"string",[{ eexpr = TIf (_,{ eexpr = TConst (TString _)},Some { eexpr = TConst (TString _) }) } as e] ->
  85. Some e
  86. | ([],"Std"),"string",[{ eexpr = TLocal v | TField({ eexpr = TLocal v },_) } as ev] when (com.platform = Js || com.platform = Flash) && not (Meta.has Meta.CompilerGenerated v.v_meta) ->
  87. let pos = ev.epos in
  88. let stringv() =
  89. let to_str = mk (TBinop (Ast.OpAdd, mk (TConst (TString "")) com.basic.tstring pos, ev)) com.basic.tstring pos in
  90. if com.platform = Js || is_nullable ev.etype then
  91. let chk_null = mk (TBinop (Ast.OpEq, ev, mk (TConst TNull) t_dynamic pos)) com.basic.tbool pos in
  92. mk (TIf (chk_null, mk (TConst (TString "null")) com.basic.tstring pos, Some to_str)) com.basic.tstring pos
  93. else
  94. to_str
  95. in
  96. (match follow ev.etype with
  97. | TInst ({ cl_path = [],"String" }, []) ->
  98. Some (stringv())
  99. | TAbstract ({ a_path = [],"Float" }, []) ->
  100. Some (stringv())
  101. | TAbstract ({ a_path = [],"Int" }, []) ->
  102. Some (stringv())
  103. | TAbstract ({ a_path = [],"UInt" }, []) ->
  104. Some (stringv())
  105. | TAbstract ({ a_path = [],"Bool" }, []) ->
  106. Some (stringv())
  107. | _ ->
  108. None)
  109. | ([],"Std"),"int",[{ eexpr = TConst (TFloat f) }] ->
  110. let f = float_of_string f in
  111. (match classify_float f with
  112. | FP_infinite | FP_nan ->
  113. None
  114. | _ when f <= Int32.to_float Int32.min_int -. 1. || f >= Int32.to_float Int32.max_int +. 1. ->
  115. None (* out range, keep platform-specific behavior *)
  116. | _ ->
  117. Some { eexpr = TConst (TInt (Int32.of_float f)); etype = com.basic.tint; epos = p })
  118. | ([],"Math"),"ceil",[{ eexpr = TConst (TFloat f) }] ->
  119. let f = float_of_string f in
  120. (match classify_float f with
  121. | FP_infinite | FP_nan ->
  122. None
  123. | _ when f <= Int32.to_float Int32.min_int -. 1. || f >= Int32.to_float Int32.max_int ->
  124. None (* out range, keep platform-specific behavior *)
  125. | _ ->
  126. Some { eexpr = TConst (TInt (Int32.of_float (ceil f))); etype = com.basic.tint; epos = p })
  127. | ([],"Math"),"floor",[{ eexpr = TConst (TFloat f) }] ->
  128. let f = float_of_string f in
  129. (match classify_float f with
  130. | FP_infinite | FP_nan ->
  131. None
  132. | _ when f <= Int32.to_float Int32.min_int || f >= Int32.to_float Int32.max_int +. 1. ->
  133. None (* out range, keep platform-specific behavior *)
  134. | _ ->
  135. Some { eexpr = TConst (TInt (Int32.of_float (floor f))); etype = com.basic.tint; epos = p })
  136. | (["cs"],"Lib"),("fixed" | "checked" | "unsafe"),[e] ->
  137. Some (mk_untyped_call ("__" ^ field ^ "__") p [e])
  138. | (["cs"],"Lib"),("lock"),[obj;block] ->
  139. Some (mk_untyped_call ("__lock__") p [obj;mk_block block])
  140. | (["java"],"Lib"),("lock"),[obj;block] ->
  141. Some (mk_untyped_call ("__lock__") p [obj;mk_block block])
  142. | _ ->
  143. None
  144. let api_inline ctx c field params p = match c.cl_path, field, params with
  145. | ([],"Std"),"is",[o;t] | (["js"],"Boot"),"__instanceof",[o;t] when ctx.com.platform = Js ->
  146. let mk_local ctx n t pos =
  147. mk (TLocal (try
  148. PMap.find n ctx.locals
  149. with _ ->
  150. let v = add_local ctx n t in
  151. v.v_meta <- [Meta.Unbound,[],p];
  152. v
  153. )) t pos in
  154. let tstring = ctx.com.basic.tstring in
  155. let tbool = ctx.com.basic.tbool in
  156. let tint = ctx.com.basic.tint in
  157. let is_trivial e =
  158. match e.eexpr with
  159. | TConst _ | TLocal _ -> true
  160. | _ -> false
  161. in
  162. let typeof t =
  163. let tof = mk_local ctx "__typeof__" (tfun [o.etype] tstring) p in
  164. let tof = mk (TCall (tof, [o])) tstring p in
  165. mk (TBinop (Ast.OpEq, tof, (mk (TConst (TString t)) tstring p))) tbool p
  166. in
  167. (match t.eexpr with
  168. (* generate simple typeof checks for basic types *)
  169. | TTypeExpr (TClassDecl ({ cl_path = [],"String" })) -> Some (typeof "string")
  170. | TTypeExpr (TAbstractDecl ({ a_path = [],"Bool" })) -> Some (typeof "boolean")
  171. | TTypeExpr (TAbstractDecl ({ a_path = [],"Float" })) -> Some (typeof "number")
  172. | TTypeExpr (TAbstractDecl ({ a_path = [],"Int" })) when is_trivial o ->
  173. (* generate (o|0) === o check *)
  174. let teq = mk_local ctx "__strict_eq__" (tfun [tint; tint] tbool) p in
  175. let lhs = mk (TBinop (Ast.OpOr, o, mk (TConst (TInt Int32.zero)) tint p)) tint p in
  176. Some (mk (TCall (teq, [lhs; o])) tbool p)
  177. | TTypeExpr (TClassDecl ({ cl_path = [],"Array" })) ->
  178. (* generate (o instanceof Array) && o.__enum__ == null check *)
  179. let iof = mk_local ctx "__instanceof__" (tfun [o.etype;t.etype] tbool) p in
  180. let iof = mk (TCall (iof, [o; t])) tbool p in
  181. let enum = mk (TField (o, FDynamic "__enum__")) (mk_mono()) p in
  182. let null = mk (TConst TNull) (mk_mono()) p in
  183. let not_enum = mk (TBinop (Ast.OpEq, enum, null)) tbool p in
  184. Some (mk (TBinop (Ast.OpBoolAnd, iof, not_enum)) tbool p)
  185. | _ ->
  186. None)
  187. | (["cs" | "java"],"Lib"),("nativeArray"),[{ eexpr = TArrayDecl args } as edecl; _]
  188. | (["haxe";"ds";"_Vector"],"Vector_Impl_"),("fromArrayCopy"),[{ eexpr = TArrayDecl args } as edecl] -> (try
  189. let platf = match ctx.com.platform with
  190. | Cs -> "cs"
  191. | Java -> "java"
  192. | _ -> raise Exit
  193. in
  194. let mpath = if field = "fromArrayCopy" then
  195. (["haxe";"ds"],"Vector")
  196. else
  197. ([platf],"NativeArray")
  198. in
  199. let m = ctx.g.do_load_module ctx mpath null_pos in
  200. let main = List.find (function | TClassDecl _ | TAbstractDecl _ -> true | _ -> false) m.m_types in
  201. let t = match follow edecl.etype, main with
  202. | TInst({ cl_path = [],"Array" }, [t]), TClassDecl(cl) ->
  203. TInst(cl,[t])
  204. | TInst({ cl_path = [],"Array" }, [t]), TAbstractDecl(a) ->
  205. TAbstract(a,[t])
  206. | _ -> assert false
  207. in
  208. Some ({ (mk_untyped_call "__array__" p args) with etype = t })
  209. with | Exit ->
  210. None)
  211. | _ ->
  212. api_inline2 ctx.com c field params p
  213. (* ---------------------------------------------------------------------- *)
  214. (* INLINING *)
  215. type in_local = {
  216. i_var : tvar;
  217. i_subst : tvar;
  218. mutable i_captured : bool;
  219. mutable i_write : bool;
  220. mutable i_read : int;
  221. mutable i_force_temp : bool;
  222. }
  223. let inline_default_config cf t =
  224. (* type substitution on both class and function type parameters *)
  225. let rec get_params c pl =
  226. match c.cl_super with
  227. | None -> c.cl_params, pl
  228. | Some (csup,spl) ->
  229. let spl = (match apply_params c.cl_params pl (TInst (csup,spl)) with
  230. | TInst (_,pl) -> pl
  231. | _ -> assert false
  232. ) in
  233. let ct, cpl = get_params csup spl in
  234. c.cl_params @ ct, pl @ cpl
  235. in
  236. let tparams = (match follow t with
  237. | TInst (c,pl) -> get_params c pl
  238. | _ -> ([],[]))
  239. in
  240. let pmonos = List.map (fun _ -> mk_mono()) cf.cf_params in
  241. let tmonos = snd tparams @ pmonos in
  242. let tparams = fst tparams @ cf.cf_params in
  243. tparams <> [], apply_params tparams tmonos
  244. let rec type_inline ctx cf f ethis params tret config p ?(self_calling_closure=false) force =
  245. (* perform some specific optimization before we inline the call since it's not possible to detect at final optimization time *)
  246. try
  247. let cl = (match follow ethis.etype with
  248. | TInst (c,_) -> c
  249. | TAnon a -> (match !(a.a_status) with Statics c -> c | _ -> raise Exit)
  250. | _ -> raise Exit
  251. ) in
  252. (match api_inline ctx cl cf.cf_name params p with
  253. | None -> raise Exit
  254. | Some e -> Some e)
  255. with Exit ->
  256. let has_params,map_type = match config with Some config -> config | None -> inline_default_config cf ethis.etype in
  257. (* locals substitution *)
  258. let locals = Hashtbl.create 0 in
  259. let local v =
  260. try
  261. Hashtbl.find locals v.v_id
  262. with Not_found ->
  263. let v' = alloc_var v.v_name v.v_type in
  264. if Meta.has Meta.Unbound v.v_meta then v'.v_meta <- [Meta.Unbound,[],p];
  265. let i = {
  266. i_var = v;
  267. i_subst = v';
  268. i_captured = false;
  269. i_write = false;
  270. i_force_temp = false;
  271. i_read = 0;
  272. } in
  273. i.i_subst.v_meta <- v.v_meta;
  274. Hashtbl.add locals v.v_id i;
  275. Hashtbl.add locals i.i_subst.v_id i;
  276. i
  277. in
  278. let in_local_fun = ref false in
  279. let read_local v =
  280. let l = try
  281. Hashtbl.find locals v.v_id
  282. with Not_found ->
  283. (* make sure to duplicate unbound inline variable to prevent dependency leak when unifying monomorph *)
  284. if has_meta Meta.Unbound v.v_meta then local v else
  285. {
  286. i_var = v;
  287. i_subst = v;
  288. i_captured = false;
  289. i_write = false;
  290. i_force_temp = false;
  291. i_read = 0;
  292. }
  293. in
  294. if !in_local_fun then l.i_captured <- true;
  295. l
  296. in
  297. (* use default values for null/unset arguments *)
  298. let rec loop pl al first =
  299. match pl, al with
  300. | _, [] -> []
  301. | e :: pl, (v, opt) :: al ->
  302. (*
  303. if we pass a Null<T> var to an inlined method that needs a T.
  304. we need to force a local var to be created on some platforms.
  305. *)
  306. if ctx.com.config.pf_static && not (is_nullable v.v_type) && is_null e.etype then (local v).i_force_temp <- true;
  307. (*
  308. if we cast from Dynamic, create a local var as well to do the cast
  309. once and allow DCE to perform properly.
  310. *)
  311. if v.v_type != t_dynamic && follow e.etype == t_dynamic then (local v).i_write <- true;
  312. (match e.eexpr, opt with
  313. | TConst TNull , Some c -> mk (TConst c) v.v_type e.epos
  314. (*
  315. This is really weird and should be reviewed again. The problem is that we cannot insert a TCast here because
  316. the abstract `this` value could be written to, which is not possible if it is wrapped in a cast.
  317. The original problem here is that we do not generate a temporary variable and thus mute the type of the
  318. `this` variable, which leads to unification errors down the line. See issues #2236 and #3713.
  319. *)
  320. (* | _ when first && (Meta.has Meta.Impl cf.cf_meta) -> {e with etype = v.v_type} *)
  321. | _ -> e) :: loop pl al false
  322. | [], (v,opt) :: al ->
  323. (mk (TConst (match opt with None -> TNull | Some c -> c)) v.v_type p) :: loop [] al false
  324. in
  325. (*
  326. Build the expr/var subst list
  327. *)
  328. let ethis = (match ethis.eexpr with TConst TSuper -> { ethis with eexpr = TConst TThis } | _ -> ethis) in
  329. let vthis = alloc_var "_this" ethis.etype in
  330. let inlined_vars = List.map2 (fun e (v,_) ->
  331. let l = local v in
  332. if has_side_effect e then l.i_force_temp <- true; (* force tmp var *)
  333. l, e
  334. ) (ethis :: loop params f.tf_args true) ((vthis,None) :: f.tf_args) in
  335. let inlined_vars = List.rev inlined_vars in
  336. (*
  337. here, we try to eliminate final returns from the expression tree.
  338. However, this is not entirely correct since we don't yet correctly propagate
  339. the type of returned expressions upwards ("return" expr itself being Dynamic).
  340. We also substitute variables with fresh ones that might be renamed at later stage.
  341. *)
  342. let opt f = function
  343. | None -> None
  344. | Some e -> Some (f e)
  345. in
  346. let has_vars = ref false in
  347. let in_loop = ref false in
  348. let cancel_inlining = ref false in
  349. let has_return_value = ref false in
  350. let ret_val = (match follow f.tf_type with TAbstract ({ a_path = ([],"Void") },[]) -> false | _ -> true) in
  351. let map_pos = if self_calling_closure then (fun e -> e) else (fun e -> { e with epos = p }) in
  352. let rec map term e =
  353. let po = e.epos in
  354. let e = map_pos e in
  355. match e.eexpr with
  356. | TLocal v ->
  357. let l = read_local v in
  358. l.i_read <- l.i_read + (if !in_loop then 2 else 1);
  359. (* never inline a function which contain a delayed macro because its bound
  360. to its variables and not the calling method *)
  361. if v.v_name = "__dollar__delay_call" then cancel_inlining := true;
  362. let e = { e with eexpr = TLocal l.i_subst } in
  363. if Meta.has Meta.This v.v_meta then mk (TCast(e,None)) v.v_type e.epos else e
  364. | TConst TThis ->
  365. let l = read_local vthis in
  366. l.i_read <- l.i_read + (if !in_loop then 2 else 1);
  367. { e with eexpr = TLocal l.i_subst }
  368. | TVar (v,eo) ->
  369. has_vars := true;
  370. { e with eexpr = TVar ((local v).i_subst,opt (map false) eo)}
  371. | TReturn eo when not !in_local_fun ->
  372. if not term then error "Cannot inline a not final return" po;
  373. (match eo with
  374. | None -> mk (TConst TNull) f.tf_type p
  375. | Some e ->
  376. has_return_value := true;
  377. map term e)
  378. | TFor (v,e1,e2) ->
  379. let i = local v in
  380. let e1 = map false e1 in
  381. let old = !in_loop in
  382. in_loop := true;
  383. let e2 = map false e2 in
  384. in_loop := old;
  385. { e with eexpr = TFor (i.i_subst,e1,e2) }
  386. | TWhile (cond,eloop,flag) ->
  387. let cond = map false cond in
  388. let old = !in_loop in
  389. in_loop := true;
  390. let eloop = map false eloop in
  391. in_loop := old;
  392. { e with eexpr = TWhile (cond,eloop,flag) }
  393. | TSwitch (e1,cases,def) when term ->
  394. let term = term && (def <> None || is_exhaustive e1) in
  395. let cases = List.map (fun (el,e) ->
  396. let el = List.map (map false) el in
  397. el, map term e
  398. ) cases in
  399. let def = opt (map term) def in
  400. { e with eexpr = TSwitch (map false e1,cases,def); etype = if ret_val then unify_min ctx ((List.map snd cases) @ (match def with None -> [] | Some e -> [e])) else e.etype }
  401. | TTry (e1,catches) ->
  402. { e with eexpr = TTry (map term e1,List.map (fun (v,e) ->
  403. let lv = (local v).i_subst in
  404. let e = map term e in
  405. lv,e
  406. ) catches); etype = if term && ret_val then unify_min ctx (e1::List.map snd catches) else e.etype }
  407. | TBlock l ->
  408. let old = save_locals ctx in
  409. let t = ref e.etype in
  410. let rec has_term_return e =
  411. let rec loop e =
  412. let r = match e.eexpr with
  413. | TReturn _ -> true
  414. | TIf (_,_,None) | TSwitch (_,_,None) | TFor _ | TWhile (_,_,NormalWhile) -> false (* we might not enter this code at all *)
  415. | TTry (a, catches) -> List.for_all has_term_return (a :: List.map snd catches)
  416. | TIf (cond,a,Some b) -> has_term_return cond || (has_term_return a && has_term_return b)
  417. | TSwitch (cond,cases,Some def) -> has_term_return cond || List.for_all has_term_return (def :: List.map snd cases)
  418. | TBinop (OpBoolAnd,a,b) -> has_term_return a && has_term_return b
  419. | _ -> Type.iter loop e; false
  420. in
  421. if r then raise Exit
  422. in
  423. try loop e; false with Exit -> true
  424. in
  425. let rec loop = function
  426. | [] when term ->
  427. t := mk_mono();
  428. [mk (TConst TNull) (!t) p]
  429. | [] -> []
  430. | [e] ->
  431. let e = map term e in
  432. if term then t := e.etype;
  433. [e]
  434. | ({ eexpr = TIf (cond,e1,None) } as e) :: l when term && has_term_return e1 ->
  435. loop [{ e with eexpr = TIf (cond,e1,Some (mk (TBlock l) e.etype e.epos)); epos = punion e.epos (match List.rev l with e :: _ -> e.epos | [] -> assert false) }]
  436. | e :: l ->
  437. let e = map false e in
  438. e :: loop l
  439. in
  440. let l = loop l in
  441. old();
  442. { e with eexpr = TBlock l; etype = !t }
  443. | TIf (econd,eif,Some eelse) when term ->
  444. let econd = map false econd in
  445. let eif = map term eif in
  446. let eelse = map term eelse in
  447. { e with eexpr = TIf(econd,eif,Some eelse); etype = if ret_val then unify_min ctx [eif;eelse] else e.etype }
  448. | TParenthesis e1 ->
  449. let e1 = map term e1 in
  450. mk (TParenthesis e1) e1.etype e.epos
  451. | TUnop ((Increment|Decrement) as op,flag,({ eexpr = TLocal v } as e1)) ->
  452. let l = read_local v in
  453. l.i_write <- true;
  454. {e with eexpr = TUnop(op,flag,{e1 with eexpr = TLocal l.i_subst})}
  455. | TBinop ((OpAssign | OpAssignOp _) as op,({ eexpr = TLocal v } as e1),e2) ->
  456. let l = read_local v in
  457. l.i_write <- true;
  458. let e2 = map false e2 in
  459. {e with eexpr = TBinop(op,{e1 with eexpr = TLocal l.i_subst},e2)}
  460. | TObjectDecl fl ->
  461. let fl = List.map (fun (s,e) -> s,map false e) fl in
  462. begin match follow e.etype with
  463. | TAnon an when (match !(an.a_status) with Const -> true | _ -> false) ->
  464. {e with eexpr = TObjectDecl fl; etype = TAnon { an with a_status = ref Closed}}
  465. | _ ->
  466. {e with eexpr = TObjectDecl fl}
  467. end
  468. | TFunction f ->
  469. (match f.tf_args with [] -> () | _ -> has_vars := true);
  470. let old = save_locals ctx and old_fun = !in_local_fun in
  471. let args = List.map (function(v,c) -> (local v).i_subst, c) f.tf_args in
  472. in_local_fun := true;
  473. let expr = map false f.tf_expr in
  474. in_local_fun := old_fun;
  475. old();
  476. { e with eexpr = TFunction { tf_args = args; tf_expr = expr; tf_type = f.tf_type } }
  477. | TConst TSuper ->
  478. error "Cannot inline function containing super" po
  479. | TMeta(m,e1) ->
  480. let e1 = map term e1 in
  481. {e with eexpr = TMeta(m,e1)}
  482. | _ ->
  483. Type.map_expr (map false) e
  484. in
  485. let e = map true f.tf_expr in
  486. (*
  487. if variables are not written and used with a const value, let's substitute
  488. with the actual value, either create a temp var
  489. *)
  490. let subst = ref PMap.empty in
  491. let is_constant e =
  492. let rec loop e =
  493. match e.eexpr with
  494. | TLocal _
  495. | TConst TThis (* not really, but should not be move inside a function body *)
  496. -> raise Exit
  497. | TField (_,FEnum _)
  498. | TTypeExpr _
  499. | TConst _ -> ()
  500. | _ ->
  501. Type.iter loop e
  502. in
  503. try loop e; true with Exit -> false
  504. in
  505. let is_writable e =
  506. match e.eexpr with
  507. | TField _ | TEnumParameter _ | TLocal _ | TArray _ -> true
  508. | _ -> false
  509. in
  510. let force = ref force in
  511. let vars = List.fold_left (fun acc (i,e) ->
  512. let flag = not i.i_force_temp && (match e.eexpr with
  513. | TLocal v when Meta.has Meta.This v.v_meta -> true
  514. | TLocal _ | TConst _ -> not i.i_write
  515. | TFunction _ -> if i.i_write then error "Cannot modify a closure parameter inside inline method" p; true
  516. | _ -> not i.i_write && i.i_read <= 1
  517. ) in
  518. let flag = flag && (not i.i_captured || is_constant e) in
  519. (* force inlining if we modify 'this' *)
  520. if i.i_write && (Meta.has Meta.This i.i_var.v_meta) then force := true;
  521. (* force inlining of 'this' variable if it is written *)
  522. let flag = if not flag && (Meta.has Meta.This i.i_var.v_meta) && i.i_write then begin
  523. if not (is_writable e) then error "Cannot modify the abstract value, store it into a local first" p;
  524. true
  525. end else flag in
  526. if flag then begin
  527. subst := PMap.add i.i_subst.v_id e !subst;
  528. acc
  529. end else
  530. (i.i_subst,Some e) :: acc
  531. ) [] inlined_vars in
  532. let subst = !subst in
  533. let rec inline_params e =
  534. match e.eexpr with
  535. | TLocal v -> (try PMap.find v.v_id subst with Not_found -> e)
  536. | _ -> Type.map_expr inline_params e
  537. in
  538. let e = (if PMap.is_empty subst then e else inline_params e) in
  539. let init = match vars with [] -> None | l -> Some l in
  540. (*
  541. If we have local variables and returning a value, then this will result in
  542. unoptimized JS code, so let's instead skip inlining.
  543. This could be fixed with better post process code cleanup (planed)
  544. *)
  545. if !cancel_inlining || (not (Common.defined ctx.com Define.Analyzer) && Common.platform ctx.com Js && not !force && (init <> None || !has_vars)) then
  546. None
  547. else
  548. let wrap e =
  549. (* we can't mute the type of the expression because it is not correct to do so *)
  550. let etype = if has_params then map_type e.etype else e.etype in
  551. (* if the expression is "untyped" and we don't want to unify it accidentally ! *)
  552. try (match follow e.etype with
  553. | TMono _ | TInst ({cl_kind = KTypeParameter _ },_) ->
  554. (match follow tret with
  555. | TAbstract ({ a_path = [],"Void" },_) -> e
  556. | _ -> raise (Unify_error []))
  557. | _ ->
  558. type_eq (if ctx.com.config.pf_static then EqDoNotFollowNull else EqStrict) etype tret;
  559. e)
  560. with Unify_error _ ->
  561. mk (TCast (e,None)) tret e.epos
  562. in
  563. let e = (match e.eexpr, init with
  564. | _, None when not !has_return_value ->
  565. {e with etype = tret}
  566. | TBlock [e] , None -> wrap e
  567. | _ , None -> wrap e
  568. | TBlock l, Some vl ->
  569. let el_v = List.map (fun (v,eo) -> mk (TVar (v,eo)) ctx.t.tvoid e.epos) vl in
  570. mk (TBlock (el_v @ l)) tret e.epos
  571. | _, Some vl ->
  572. let el_v = List.map (fun (v,eo) -> mk (TVar (v,eo)) ctx.t.tvoid e.epos) vl in
  573. mk (TBlock (el_v @ [e])) tret e.epos
  574. ) in
  575. let inline_meta e meta = match meta with
  576. | Meta.Deprecated,_,_ -> mk (TMeta(meta,e)) e.etype e.epos
  577. | _ -> e
  578. in
  579. let e = List.fold_left inline_meta e cf.cf_meta in
  580. (* we need to replace type-parameters that were used in the expression *)
  581. if not has_params then
  582. Some e
  583. else
  584. let mt = map_type cf.cf_type in
  585. let unify_func () = unify_raise ctx mt (TFun (List.map (fun e -> "",false,e.etype) params,tret)) p in
  586. (match follow ethis.etype with
  587. | TAnon a -> (match !(a.a_status) with
  588. | Statics {cl_kind = KAbstractImpl a } when Meta.has Meta.Impl cf.cf_meta ->
  589. if cf.cf_name <> "_new" then begin
  590. (* the first argument must unify with a_this for abstract implementation functions *)
  591. let tb = (TFun(("",false,map_type a.a_this) :: List.map (fun e -> "",false,e.etype) (List.tl params),tret)) in
  592. unify_raise ctx mt tb p
  593. end
  594. | _ -> unify_func())
  595. | _ -> unify_func());
  596. (*
  597. this is very expensive since we are building the substitution list for
  598. every expression, but hopefully in such cases the expression size is small
  599. *)
  600. let vars = Hashtbl.create 0 in
  601. let map_var v =
  602. if not (Hashtbl.mem vars v.v_id) then begin
  603. Hashtbl.add vars v.v_id ();
  604. v.v_type <- map_type v.v_type;
  605. end;
  606. v
  607. in
  608. let rec map_expr_type e = Type.map_expr_type map_expr_type map_type map_var e in
  609. Some (map_expr_type e)
  610. (* ---------------------------------------------------------------------- *)
  611. (* LOOPS *)
  612. let rec optimize_for_loop ctx (i,pi) e1 e2 p =
  613. let t_void = ctx.t.tvoid in
  614. let t_int = ctx.t.tint in
  615. let lblock el = Some (mk (TBlock el) t_void p) in
  616. let mk_field e n =
  617. TField (e,try quick_field e.etype n with Not_found -> assert false)
  618. in
  619. let gen_int_iter pt f_get f_length =
  620. let i = add_local ctx i pt in
  621. let index = gen_local ctx t_int in
  622. let arr, avars = (match e1.eexpr with
  623. | TLocal _ -> e1, None
  624. | _ ->
  625. let atmp = gen_local ctx e1.etype in
  626. mk (TLocal atmp) e1.etype e1.epos, (Some (atmp,Some e1))
  627. ) in
  628. let iexpr = mk (TLocal index) t_int p in
  629. let e2 = type_expr ctx e2 NoValue in
  630. let aget = mk (TVar (i,Some (f_get arr iexpr pt p))) t_void pi in
  631. let incr = mk (TUnop (Increment,Prefix,iexpr)) t_int p in
  632. let block = match e2.eexpr with
  633. | TBlock el -> mk (TBlock (aget :: incr :: el)) t_void e2.epos
  634. | _ -> mk (TBlock [aget;incr;e2]) t_void p
  635. in
  636. let ivar = Some (mk (TConst (TInt 0l)) t_int p) in
  637. let elength = f_length arr p in
  638. let el = [mk (TWhile (
  639. mk (TBinop (OpLt, iexpr, elength)) ctx.t.tbool p,
  640. block,
  641. NormalWhile
  642. )) t_void p;
  643. ] in
  644. let el = match avars with None -> el | Some (v,eo) -> (mk (TVar (v,eo)) t_void p) :: el in
  645. let el = (mk (TVar (index,ivar)) t_void p) :: el in
  646. lblock el
  647. in
  648. let get_next_array_element arr iexpr pt p =
  649. (mk (TArray (arr,iexpr)) pt p)
  650. in
  651. let get_array_length arr p =
  652. mk (mk_field arr "length") ctx.com.basic.tint p
  653. in
  654. match e1.eexpr, follow e1.etype with
  655. | TNew ({ cl_path = ([],"IntIterator") },[],[i1;i2]) , _ ->
  656. let max = (match i1.eexpr , i2.eexpr with
  657. | TConst (TInt a), TConst (TInt b) when Int32.compare b a < 0 -> error "Range operator can't iterate backwards" p
  658. | _, TConst _ | _ , TLocal _ -> None
  659. | _ -> Some (gen_local ctx t_int)
  660. ) in
  661. let tmp = gen_local ctx t_int in
  662. let i = add_local ctx i t_int in
  663. let rec check e =
  664. match e.eexpr with
  665. | TBinop (OpAssign,{ eexpr = TLocal l },_)
  666. | TBinop (OpAssignOp _,{ eexpr = TLocal l },_)
  667. | TUnop (Increment,_,{ eexpr = TLocal l })
  668. | TUnop (Decrement,_,{ eexpr = TLocal l }) when l == i ->
  669. error "Loop variable cannot be modified" e.epos
  670. | _ ->
  671. Type.iter check e
  672. in
  673. let e2 = type_expr ctx e2 NoValue in
  674. check e2;
  675. let etmp = mk (TLocal tmp) t_int p in
  676. let incr = mk (TUnop (Increment,Postfix,etmp)) t_int p in
  677. let init = mk (TVar (i,Some incr)) t_void pi in
  678. let block = match e2.eexpr with
  679. | TBlock el -> mk (TBlock (init :: el)) t_void e2.epos
  680. | _ -> mk (TBlock [init;e2]) t_void p
  681. in
  682. (*
  683. force locals to be of Int type (to prevent Int/UInt issues)
  684. *)
  685. let i2 = match follow i2.etype with
  686. | TAbstract ({ a_path = ([],"Int") }, []) -> i2
  687. | _ -> { i2 with eexpr = TCast(i2, None); etype = t_int }
  688. in
  689. (match max with
  690. | None ->
  691. lblock [
  692. mk (TVar (tmp,Some i1)) t_void p;
  693. mk (TWhile (
  694. mk (TBinop (OpLt, etmp, i2)) ctx.t.tbool p,
  695. block,
  696. NormalWhile
  697. )) t_void p;
  698. ]
  699. | Some max ->
  700. lblock [
  701. mk (TVar (tmp,Some i1)) t_void p;
  702. mk (TVar (max,Some i2)) t_void p;
  703. mk (TWhile (
  704. mk (TBinop (OpLt, etmp, mk (TLocal max) t_int p)) ctx.t.tbool p,
  705. block,
  706. NormalWhile
  707. )) t_void p;
  708. ])
  709. | TArrayDecl el, TInst({ cl_path = [],"Array" },[pt]) when false ->
  710. begin try
  711. let num_expr = ref 0 in
  712. let rec loop e = match fst e with
  713. | EContinue | EBreak ->
  714. raise Exit
  715. | _ ->
  716. incr num_expr;
  717. Ast.map_expr loop e
  718. in
  719. ignore(loop e2);
  720. let v = add_local ctx i pt in
  721. let e2 = type_expr ctx e2 NoValue in
  722. let cost = (List.length el) * !num_expr in
  723. let max_cost = try
  724. int_of_string (Common.defined_value ctx.com Define.LoopUnrollMaxCost)
  725. with Not_found ->
  726. 250
  727. in
  728. if cost > max_cost then raise Exit;
  729. let eloc = mk (TLocal v) v.v_type p in
  730. let el = List.map (fun e ->
  731. let e_assign = mk (TBinop(OpAssign,eloc,e)) e.etype e.epos in
  732. concat e_assign e2
  733. ) el in
  734. let ev = mk (TVar(v, None)) ctx.t.tvoid p in
  735. Some (mk (TBlock (ev :: el)) ctx.t.tvoid p)
  736. with Exit ->
  737. gen_int_iter pt get_next_array_element get_array_length
  738. end
  739. | _ , TInst({ cl_path = [],"Array" },[pt])
  740. | _ , TInst({ cl_path = ["flash"],"Vector" },[pt]) ->
  741. gen_int_iter pt get_next_array_element get_array_length
  742. | _ , TInst({ cl_array_access = Some pt } as c,pl) when (try match follow (PMap.find "length" c.cl_fields).cf_type with TAbstract ({ a_path = [],"Int" },[]) -> true | _ -> false with Not_found -> false) && not (PMap.mem "iterator" c.cl_fields) ->
  743. gen_int_iter (apply_params c.cl_params pl pt) get_next_array_element get_array_length
  744. | _, TAbstract({a_impl = Some c} as a,tl) ->
  745. begin try
  746. let cf_length = PMap.find "get_length" c.cl_statics in
  747. let get_length e p =
  748. make_static_call ctx c cf_length (apply_params a.a_params tl) [e] ctx.com.basic.tint p
  749. in
  750. begin match follow cf_length.cf_type with
  751. | TFun(_,tr) ->
  752. begin match follow tr with
  753. | TAbstract({a_path = [],"Int"},_) -> ()
  754. | _ -> raise Not_found
  755. end
  756. | _ ->
  757. raise Not_found
  758. end;
  759. begin try
  760. (* first try: do we have an @:arrayAccess getter field? *)
  761. let todo = mk (TConst TNull) ctx.t.tint p in
  762. let cf,_,r,_,_ = (!find_array_access_raise_ref) ctx a tl todo None p in
  763. let get_next e_base e_index t p =
  764. make_static_call ctx c cf (apply_params a.a_params tl) [e_base;e_index] r p
  765. in
  766. gen_int_iter r get_next get_length
  767. with Not_found ->
  768. (* second try: do we have @:arrayAccess on the abstract itself? *)
  769. if not (Meta.has Meta.ArrayAccess a.a_meta) then raise Not_found;
  770. (* let's allow this only for core-type abstracts *)
  771. if not (Meta.has Meta.CoreType a.a_meta) then raise Not_found;
  772. (* in which case we assume that a singular type parameter is the element type *)
  773. let t = match tl with [t] -> t | _ -> raise Not_found in
  774. gen_int_iter t get_next_array_element get_length
  775. end with Not_found ->
  776. None
  777. end
  778. | _ , TInst ({ cl_kind = KGenericInstance ({ cl_path = ["haxe";"ds"],"GenericStack" },[t]) } as c,[]) ->
  779. let tcell = (try (PMap.find "head" c.cl_fields).cf_type with Not_found -> assert false) in
  780. let i = add_local ctx i t in
  781. let cell = gen_local ctx tcell in
  782. let cexpr = mk (TLocal cell) tcell p in
  783. let e2 = type_expr ctx e2 NoValue in
  784. let evar = mk (TVar (i,Some (mk (mk_field cexpr "elt") t p))) t_void pi in
  785. let enext = mk (TBinop (OpAssign,cexpr,mk (mk_field cexpr "next") tcell p)) tcell p in
  786. let block = match e2.eexpr with
  787. | TBlock el -> mk (TBlock (evar :: enext :: el)) t_void e2.epos
  788. | _ -> mk (TBlock [evar;enext;e2]) t_void p
  789. in
  790. lblock [
  791. mk (TVar (cell,Some (mk (mk_field e1 "head") tcell p))) t_void p;
  792. mk (TWhile (
  793. mk (TBinop (OpNotEq, cexpr, mk (TConst TNull) tcell p)) ctx.t.tbool p,
  794. block,
  795. NormalWhile
  796. )) t_void p
  797. ]
  798. | _ ->
  799. None
  800. let optimize_for_loop_iterator ctx v e1 e2 p =
  801. let c,tl = (match follow e1.etype with TInst (c,pl) -> c,pl | _ -> raise Exit) in
  802. let _, _, fhasnext = (try raw_class_field (fun cf -> apply_params c.cl_params tl cf.cf_type) c tl "hasNext" with Not_found -> raise Exit) in
  803. if fhasnext.cf_kind <> Method MethInline then raise Exit;
  804. let tmp = gen_local ctx e1.etype in
  805. let eit = mk (TLocal tmp) e1.etype p in
  806. let ehasnext = make_call ctx (mk (TField (eit,FInstance (c, tl, fhasnext))) (TFun([],ctx.t.tbool)) p) [] ctx.t.tbool p in
  807. let enext = mk (TVar (v,Some (make_call ctx (mk (TField (eit,quick_field_dynamic eit.etype "next")) (TFun ([],v.v_type)) p) [] v.v_type p))) ctx.t.tvoid p in
  808. let eblock = (match e2.eexpr with
  809. | TBlock el -> { e2 with eexpr = TBlock (enext :: el) }
  810. | _ -> mk (TBlock [enext;e2]) ctx.t.tvoid p
  811. ) in
  812. mk (TBlock [
  813. mk (TVar (tmp,Some e1)) ctx.t.tvoid p;
  814. mk (TWhile (ehasnext,eblock,NormalWhile)) ctx.t.tvoid p
  815. ]) ctx.t.tvoid p
  816. (* ---------------------------------------------------------------------- *)
  817. (* SANITIZE *)
  818. (*
  819. makes sure that when an AST get generated to source code, it will not
  820. generate expressions that evaluate differently. It is then necessary to
  821. add parenthesises around some binary expressions when the AST does not
  822. correspond to the natural operand priority order for the platform
  823. *)
  824. (*
  825. this is the standard C++ operator precedence, which is also used by both JS and PHP
  826. *)
  827. let standard_precedence op =
  828. let left = true and right = false in
  829. match op with
  830. | OpMult | OpDiv | OpMod -> 5, left
  831. | OpAdd | OpSub -> 6, left
  832. | OpShl | OpShr | OpUShr -> 7, left
  833. | OpLt | OpLte | OpGt | OpGte -> 8, left
  834. | OpEq | OpNotEq -> 9, left
  835. | OpAnd -> 10, left
  836. | OpXor -> 11, left
  837. | OpOr -> 12, left
  838. | OpInterval -> 13, right (* haxe specific *)
  839. | OpBoolAnd -> 14, left
  840. | OpBoolOr -> 15, left
  841. | OpArrow -> 16, left
  842. | OpAssignOp OpAssign -> 17, right (* mimics ?: *)
  843. | OpAssign | OpAssignOp _ -> 18, right
  844. let rec need_parent e =
  845. match e.eexpr with
  846. | TConst _ | TLocal _ | TArray _ | TField _ | TEnumParameter _ | TParenthesis _ | TMeta _ | TCall _ | TNew _ | TTypeExpr _ | TObjectDecl _ | TArrayDecl _ -> false
  847. | TCast (e,None) -> need_parent e
  848. | TCast _ | TThrow _ | TReturn _ | TTry _ | TSwitch _ | TFor _ | TIf _ | TWhile _ | TBinop _ | TContinue | TBreak
  849. | TBlock _ | TVar _ | TFunction _ | TUnop _ -> true
  850. let sanitize_expr com e =
  851. let parent e =
  852. match e.eexpr with
  853. | TParenthesis _ -> e
  854. | _ -> mk (TParenthesis e) e.etype e.epos
  855. in
  856. let block e =
  857. match e.eexpr with
  858. | TBlock _ -> e
  859. | _ -> mk (TBlock [e]) e.etype e.epos
  860. in
  861. let complex e =
  862. (* complex expressions are the one that once generated to source consists in several expressions *)
  863. match e.eexpr with
  864. | TVar _ (* needs to be put into blocks *)
  865. | TFor _ (* a temp var is needed for holding iterator *)
  866. | TCall ({ eexpr = TLocal { v_name = "__js__" } },_) (* we never know *)
  867. -> block e
  868. | _ -> e
  869. in
  870. (* tells if the printed expresssion ends with an if without else *)
  871. let rec has_if e =
  872. match e.eexpr with
  873. | TIf (_,_,None) -> true
  874. | TWhile (_,e,NormalWhile) -> has_if e
  875. | TFor (_,_,e) -> has_if e
  876. | _ -> false
  877. in
  878. match e.eexpr with
  879. | TConst TNull ->
  880. if com.config.pf_static && not (is_nullable e.etype) then begin
  881. let rec loop t = match follow t with
  882. | TMono _ -> () (* in these cases the null will cast to default value *)
  883. | TFun _ -> () (* this is a bit a particular case, maybe flash-specific actually *)
  884. (* TODO: this should use get_underlying_type, but we do not have access to Codegen here. *)
  885. | TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) -> loop (apply_params a.a_params tl a.a_this)
  886. | _ -> com.error ("On static platforms, null can't be used as basic type " ^ s_type (print_context()) e.etype) e.epos
  887. in
  888. loop e.etype
  889. end;
  890. e
  891. | TBinop (op,e1,e2) ->
  892. let swap op1 op2 =
  893. let p1, left1 = standard_precedence op1 in
  894. let p2, _ = standard_precedence op2 in
  895. left1 && p1 <= p2
  896. in
  897. let rec loop ee left =
  898. match ee.eexpr with
  899. | TBinop (op2,_,_) -> if left then not (swap op2 op) else swap op op2
  900. | TIf _ -> if left then not (swap (OpAssignOp OpAssign) op) else swap op (OpAssignOp OpAssign)
  901. | TCast (e,None) -> loop e left
  902. | _ -> false
  903. in
  904. let e1 = if loop e1 true then parent e1 else e1 in
  905. let e2 = if loop e2 false then parent e2 else e2 in
  906. { e with eexpr = TBinop (op,e1,e2) }
  907. | TUnop (op,mode,e1) ->
  908. let rec loop ee =
  909. match ee.eexpr with
  910. | TBinop _ | TIf _ | TUnop _ -> parent e1
  911. | TCast (e,None) -> loop e
  912. | _ -> e1
  913. in
  914. { e with eexpr = TUnop (op,mode,loop e1)}
  915. | TIf (e1,e2,eelse) ->
  916. let e1 = parent e1 in
  917. let e2 = (if (eelse <> None && has_if e2) || (match e2.eexpr with TIf _ -> true | _ -> false) then block e2 else complex e2) in
  918. let eelse = (match eelse with None -> None | Some e -> Some (complex e)) in
  919. { e with eexpr = TIf (e1,e2,eelse) }
  920. | TWhile (e1,e2,flag) ->
  921. let e1 = parent e1 in
  922. let e2 = complex e2 in
  923. { e with eexpr = TWhile (e1,e2,flag) }
  924. | TFor (v,e1,e2) ->
  925. let e2 = complex e2 in
  926. { e with eexpr = TFor (v,e1,e2) }
  927. | TFunction f ->
  928. let f = (match f.tf_expr.eexpr with
  929. | TBlock _ -> f
  930. | _ -> { f with tf_expr = block f.tf_expr }
  931. ) in
  932. { e with eexpr = TFunction f }
  933. | TCall (e2,args) ->
  934. if need_parent e2 then { e with eexpr = TCall(parent e2,args) } else e
  935. | TEnumParameter (e2,ef,i) ->
  936. if need_parent e2 then { e with eexpr = TEnumParameter(parent e2,ef,i) } else e
  937. | TField (e2,f) ->
  938. if need_parent e2 then { e with eexpr = TField(parent e2,f) } else e
  939. | TArray (e1,e2) ->
  940. if need_parent e1 then { e with eexpr = TArray(parent e1,e2) } else e
  941. | TTry (e1,catches) ->
  942. let e1 = block e1 in
  943. let catches = List.map (fun (v,e) -> v, block e) catches in
  944. { e with eexpr = TTry (e1,catches) }
  945. | TSwitch (e1,cases,def) ->
  946. let e1 = parent e1 in
  947. let cases = List.map (fun (el,e) -> el, complex e) cases in
  948. let def = (match def with None -> None | Some e -> Some (complex e)) in
  949. { e with eexpr = TSwitch (e1,cases,def) }
  950. | _ ->
  951. e
  952. let reduce_expr com e =
  953. match e.eexpr with
  954. | TSwitch (_,cases,_) ->
  955. List.iter (fun (cl,_) ->
  956. List.iter (fun e ->
  957. match e.eexpr with
  958. | TCall ({ eexpr = TField (_,FEnum _) },_) -> error "Not-constant enum in switch cannot be matched" e.epos
  959. | _ -> ()
  960. ) cl
  961. ) cases;
  962. e
  963. | TBlock l ->
  964. (match List.rev l with
  965. | [] -> e
  966. | ec :: l ->
  967. (* remove all no-ops : not-final constants in blocks *)
  968. match List.filter (fun e -> match e.eexpr with
  969. | TConst _
  970. | TBlock []
  971. | TObjectDecl [] ->
  972. false
  973. | _ ->
  974. true
  975. ) l with
  976. | [] -> ec
  977. | l -> { e with eexpr = TBlock (List.rev (ec :: l)) })
  978. | TParenthesis ec ->
  979. { ec with epos = e.epos }
  980. | TTry (e,[]) ->
  981. e
  982. | _ ->
  983. e
  984. let rec sanitize com e =
  985. sanitize_expr com (reduce_expr com (Type.map_expr (sanitize com) e))
  986. (* ---------------------------------------------------------------------- *)
  987. (* REDUCE *)
  988. let optimize_binop e op e1 e2 =
  989. let is_float t =
  990. match follow t with
  991. | TAbstract({ a_path = [],"Float" },_) -> true
  992. | _ -> false
  993. in
  994. let is_numeric t =
  995. match follow t with
  996. | TAbstract({ a_path = [],("Float"|"Int") },_) -> true
  997. | _ -> false
  998. in
  999. let check_float op f1 f2 =
  1000. let f = op f1 f2 in
  1001. let fstr = float_repres f in
  1002. if (match classify_float f with FP_nan | FP_infinite -> false | _ -> float_of_string fstr = f) then { e with eexpr = TConst (TFloat fstr) } else e
  1003. in
  1004. (match e1.eexpr, e2.eexpr with
  1005. | TConst (TInt 0l) , _ when op = OpAdd && is_numeric e2.etype -> e2
  1006. | TConst (TInt 1l) , _ when op = OpMult -> e2
  1007. | TConst (TFloat v) , _ when op = OpAdd && float_of_string v = 0. && is_float e2.etype -> e2
  1008. | TConst (TFloat v) , _ when op = OpMult && float_of_string v = 1. && is_float e2.etype -> e2
  1009. | _ , TConst (TInt 0l) when (match op with OpAdd -> is_numeric e1.etype | OpSub | OpShr | OpShl -> true | _ -> false) -> e1 (* bits operations might cause overflow *)
  1010. | _ , TConst (TInt 1l) when op = OpMult -> e1
  1011. | _ , TConst (TFloat v) when (match op with OpAdd | OpSub -> float_of_string v = 0. && is_float e1.etype | _ -> false) -> e1 (* bits operations might cause overflow *)
  1012. | _ , TConst (TFloat v) when op = OpMult && float_of_string v = 1. && is_float e1.etype -> e1
  1013. | TConst TNull, TConst TNull ->
  1014. (match op with
  1015. | OpEq -> { e with eexpr = TConst (TBool true) }
  1016. | OpNotEq -> { e with eexpr = TConst (TBool false) }
  1017. | _ -> e)
  1018. | TFunction _, TConst TNull ->
  1019. (match op with
  1020. | OpEq -> { e with eexpr = TConst (TBool false) }
  1021. | OpNotEq -> { e with eexpr = TConst (TBool true) }
  1022. | _ -> e)
  1023. | TConst TNull, TFunction _ ->
  1024. (match op with
  1025. | OpEq -> { e with eexpr = TConst (TBool false) }
  1026. | OpNotEq -> { e with eexpr = TConst (TBool true) }
  1027. | _ -> e)
  1028. | TConst (TInt a), TConst (TInt b) ->
  1029. let opt f = try { e with eexpr = TConst (TInt (f a b)) } with Exit -> e in
  1030. let check_overflow f =
  1031. opt (fun a b ->
  1032. let v = f (Int64.of_int32 a) (Int64.of_int32 b) in
  1033. let iv = Int64.to_int32 v in
  1034. if Int64.compare (Int64.of_int32 iv) v <> 0 then raise Exit;
  1035. iv
  1036. )
  1037. in
  1038. let ebool t =
  1039. { e with eexpr = TConst (TBool (t (Int32.compare a b) 0)) }
  1040. in
  1041. (match op with
  1042. | OpAdd -> check_overflow Int64.add
  1043. | OpSub -> check_overflow Int64.sub
  1044. | OpMult -> check_overflow Int64.mul
  1045. | OpDiv -> check_float ( /. ) (Int32.to_float a) (Int32.to_float b)
  1046. | OpAnd -> opt Int32.logand
  1047. | OpOr -> opt Int32.logor
  1048. | OpXor -> opt Int32.logxor
  1049. | OpShl -> opt (fun a b -> Int32.shift_left a (Int32.to_int b))
  1050. | OpShr -> opt (fun a b -> Int32.shift_right a (Int32.to_int b))
  1051. | OpUShr -> opt (fun a b -> Int32.shift_right_logical a (Int32.to_int b))
  1052. | OpEq -> ebool (=)
  1053. | OpNotEq -> ebool (<>)
  1054. | OpGt -> ebool (>)
  1055. | OpGte -> ebool (>=)
  1056. | OpLt -> ebool (<)
  1057. | OpLte -> ebool (<=)
  1058. | _ -> e)
  1059. | TConst ((TFloat _ | TInt _) as ca), TConst ((TFloat _ | TInt _) as cb) ->
  1060. let fa = (match ca with
  1061. | TFloat a -> float_of_string a
  1062. | TInt a -> Int32.to_float a
  1063. | _ -> assert false
  1064. ) in
  1065. let fb = (match cb with
  1066. | TFloat b -> float_of_string b
  1067. | TInt b -> Int32.to_float b
  1068. | _ -> assert false
  1069. ) in
  1070. let fop op = check_float op fa fb in
  1071. let ebool t =
  1072. { e with eexpr = TConst (TBool (t (compare fa fb) 0)) }
  1073. in
  1074. (match op with
  1075. | OpAdd -> fop (+.)
  1076. | OpDiv -> fop (/.)
  1077. | OpSub -> fop (-.)
  1078. | OpMult -> fop ( *. )
  1079. | OpEq -> ebool (=)
  1080. | OpNotEq -> ebool (<>)
  1081. | OpGt -> ebool (>)
  1082. | OpGte -> ebool (>=)
  1083. | OpLt -> ebool (<)
  1084. | OpLte -> ebool (<=)
  1085. | _ -> e)
  1086. | TConst (TBool a), TConst (TBool b) ->
  1087. let ebool f =
  1088. { e with eexpr = TConst (TBool (f a b)) }
  1089. in
  1090. (match op with
  1091. | OpEq -> ebool (=)
  1092. | OpNotEq -> ebool (<>)
  1093. | OpBoolAnd -> ebool (&&)
  1094. | OpBoolOr -> ebool (||)
  1095. | _ -> e)
  1096. | TConst a, TConst b when op = OpEq || op = OpNotEq ->
  1097. let ebool b =
  1098. { e with eexpr = TConst (TBool (if op = OpEq then b else not b)) }
  1099. in
  1100. (match a, b with
  1101. | TInt a, TFloat b | TFloat b, TInt a -> ebool (Int32.to_float a = float_of_string b)
  1102. | _ -> ebool (a = b))
  1103. | TConst (TBool a), _ ->
  1104. (match op with
  1105. | OpBoolAnd -> if a then e2 else { e with eexpr = TConst (TBool false) }
  1106. | OpBoolOr -> if a then { e with eexpr = TConst (TBool true) } else e2
  1107. | _ -> e)
  1108. | _ , TConst (TBool a) ->
  1109. (match op with
  1110. | OpBoolAnd when a -> e1
  1111. | OpBoolOr when not a -> e1
  1112. | _ -> e)
  1113. | TField (_,FEnum (e1,f1)), TField (_,FEnum (e2,f2)) when e1 == e2 ->
  1114. (match op with
  1115. | OpEq -> { e with eexpr = TConst (TBool (f1 == f2)) }
  1116. | OpNotEq -> { e with eexpr = TConst (TBool (f1 != f2)) }
  1117. | _ -> e)
  1118. | _, TCall ({ eexpr = TField (_,FEnum _) },_) | TCall ({ eexpr = TField (_,FEnum _) },_), _ ->
  1119. (match op with
  1120. | OpAssign -> e
  1121. | _ ->
  1122. error "You cannot directly compare enums with arguments. Use either 'switch' or 'Type.enumEq'" e.epos)
  1123. | _ ->
  1124. e)
  1125. let optimize_unop e op flag esub =
  1126. match op, esub.eexpr with
  1127. | Not, (TConst (TBool f) | TParenthesis({eexpr = TConst (TBool f)})) -> { e with eexpr = TConst (TBool (not f)) }
  1128. | Neg, TConst (TInt i) -> { e with eexpr = TConst (TInt (Int32.neg i)) }
  1129. | NegBits, TConst (TInt i) -> { e with eexpr = TConst (TInt (Int32.lognot i)) }
  1130. | Neg, TConst (TFloat f) ->
  1131. let v = 0. -. float_of_string f in
  1132. let vstr = float_repres v in
  1133. if float_of_string vstr = v then
  1134. { e with eexpr = TConst (TFloat vstr) }
  1135. else
  1136. e
  1137. | _ -> e
  1138. let rec reduce_loop ctx e =
  1139. let e = Type.map_expr (reduce_loop ctx) e in
  1140. sanitize_expr ctx.com (match e.eexpr with
  1141. | TIf ({ eexpr = TConst (TBool t) },e1,e2) ->
  1142. (if t then e1 else match e2 with None -> { e with eexpr = TBlock [] } | Some e -> e)
  1143. | TWhile ({ eexpr = TConst (TBool false) },sub,flag) ->
  1144. (match flag with
  1145. | NormalWhile -> { e with eexpr = TBlock [] } (* erase sub *)
  1146. | DoWhile -> e) (* we cant remove while since sub can contain continue/break *)
  1147. | TBinop (op,e1,e2) ->
  1148. optimize_binop e op e1 e2
  1149. | TUnop (op,flag,esub) ->
  1150. optimize_unop e op flag esub
  1151. | TCall ({ eexpr = TField ({ eexpr = TTypeExpr (TClassDecl c) },field) },params) ->
  1152. (match api_inline ctx c (field_name field) params e.epos with
  1153. | None -> reduce_expr ctx e
  1154. | Some e -> reduce_loop ctx e)
  1155. | TCall ({ eexpr = TFunction func } as ef,el) ->
  1156. let cf = mk_field "" ef.etype e.epos in
  1157. let ethis = mk (TConst TThis) t_dynamic e.epos in
  1158. let rt = (match follow ef.etype with TFun (_,rt) -> rt | _ -> assert false) in
  1159. let inl = (try type_inline ctx cf func ethis el rt None e.epos ~self_calling_closure:true false with Error (Custom _,_) -> None) in
  1160. (match inl with
  1161. | None -> reduce_expr ctx e
  1162. | Some e -> reduce_loop ctx e)
  1163. | TCall ({ eexpr = TField (o,FClosure (c,cf)) } as f,el) ->
  1164. let fmode = (match c with None -> FAnon cf | Some (c,tl) -> FInstance (c,tl,cf)) in
  1165. { e with eexpr = TCall ({ f with eexpr = TField (o,fmode) },el) }
  1166. | TSwitch (e1,[[{eexpr = TConst (TBool true)}],{eexpr = TConst (TBool true)}],Some ({eexpr = TConst (TBool false)})) ->
  1167. (* introduced by extractors in some cases *)
  1168. e1
  1169. | _ ->
  1170. reduce_expr ctx e)
  1171. let reduce_expression ctx e =
  1172. if ctx.com.foptimize then reduce_loop ctx e else e
  1173. let rec make_constant_expression ctx ?(concat_strings=false) e =
  1174. let e = reduce_loop ctx e in
  1175. match e.eexpr with
  1176. | TConst _ -> Some e
  1177. | TBinop ((OpAdd|OpSub|OpMult|OpDiv|OpMod) as op,e1,e2) -> (match make_constant_expression ctx e1,make_constant_expression ctx e2 with
  1178. | Some ({eexpr = TConst (TString s1)}), Some ({eexpr = TConst (TString s2)}) when concat_strings ->
  1179. Some (mk (TConst (TString (s1 ^ s2))) ctx.com.basic.tstring (punion e1.epos e2.epos))
  1180. | Some e1, Some e2 -> Some (mk (TBinop(op, e1, e2)) e.etype e.epos)
  1181. | _ -> None)
  1182. | TCast (e1, None) ->
  1183. (match make_constant_expression ctx e1 with
  1184. | None -> None
  1185. | Some e1 -> Some {e with eexpr = TCast(e1,None)})
  1186. | TParenthesis e1 ->
  1187. begin match make_constant_expression ctx ~concat_strings e1 with
  1188. | None -> None
  1189. | Some e1 -> Some {e with eexpr = TParenthesis e1}
  1190. end
  1191. | TMeta(m,e1) ->
  1192. begin match make_constant_expression ctx ~concat_strings e1 with
  1193. | None -> None
  1194. | Some e1 -> Some {e with eexpr = TMeta(m,e1)}
  1195. end
  1196. | TTypeExpr _ -> Some e
  1197. (* try to inline static function calls *)
  1198. | TCall ({ etype = TFun(_,ret); eexpr = TField (_,FStatic (c,cf)) },el) ->
  1199. (try
  1200. let func = match cf.cf_expr with Some ({eexpr = TFunction func}) -> func | _ -> raise Not_found in
  1201. let ethis = mk (TConst TThis) t_dynamic e.epos in
  1202. let inl = (try type_inline ctx cf func ethis el ret None e.epos false with Error (Custom _,_) -> None) in
  1203. (match inl with
  1204. | None -> None
  1205. | Some e -> make_constant_expression ctx e)
  1206. with Not_found -> None)
  1207. | _ -> None
  1208. (* ---------------------------------------------------------------------- *)
  1209. (* INLINE CONSTRUCTORS *)
  1210. (*
  1211. First pass :
  1212. We will look at local variables in the form var v = new ....
  1213. we only capture the ones which have constructors marked as inlined
  1214. then we make sure that these locals are no more referenced except for fields accesses
  1215. Second pass :
  1216. We replace the variables by their fields lists, and the corresponding fields accesses as well
  1217. *)
  1218. type inline_kind =
  1219. | IKCtor of tfunc * tclass_field * tclass * t list * texpr list * texpr list
  1220. | IKArray of texpr list * t
  1221. | IKStructure of (string * texpr) list
  1222. | IKNone
  1223. let inline_constructors ctx e =
  1224. let vars = ref PMap.empty in
  1225. let is_valid_ident s =
  1226. try
  1227. if String.length s = 0 then raise Exit;
  1228. begin match String.unsafe_get s 0 with
  1229. | 'a'..'z' | 'A'..'Z' | '_' -> ()
  1230. | _ -> raise Exit
  1231. end;
  1232. for i = 1 to String.length s - 1 do
  1233. match String.unsafe_get s i with
  1234. | 'a'..'z' | 'A'..'Z' | '_' -> ()
  1235. | '0'..'9' when i > 0 -> ()
  1236. | _ -> raise Exit
  1237. done;
  1238. true
  1239. with Exit ->
  1240. false
  1241. in
  1242. let rec get_inline_ctor_info e = match e.eexpr with
  1243. | TNew ({ cl_constructor = Some ({ cf_kind = Method MethInline; cf_expr = Some { eexpr = TFunction f } } as cst) } as c,tl,pl) ->
  1244. IKCtor (f,cst,c,tl,pl,[])
  1245. | TObjectDecl [] | TArrayDecl [] ->
  1246. IKNone
  1247. | TArrayDecl el ->
  1248. begin match follow e.etype with
  1249. | TInst({cl_path = [],"Array"},[t]) ->
  1250. IKArray(el,t)
  1251. | _ ->
  1252. IKNone
  1253. end
  1254. | TObjectDecl fl ->
  1255. if (List.exists (fun (s,_) -> not (is_valid_ident s)) fl) then
  1256. IKNone
  1257. else
  1258. IKStructure fl
  1259. | TCast(e,None) | TParenthesis e ->
  1260. get_inline_ctor_info e
  1261. | TBlock el ->
  1262. begin match List.rev el with
  1263. | e :: el ->
  1264. begin match get_inline_ctor_info e with
  1265. | IKCtor(f,cst,c,tl,pl,e_init) ->
  1266. IKCtor(f,cst,c,tl,pl,(List.rev el) @ e_init)
  1267. | _ ->
  1268. IKNone
  1269. end
  1270. | [] ->
  1271. IKNone
  1272. end
  1273. | _ ->
  1274. IKNone
  1275. in
  1276. let check_field v s e t =
  1277. let (a,b,fields,c,d) = PMap.find (-v.v_id) !vars in
  1278. if not (List.exists (fun (s2,_,_) -> s = s2) fields) then
  1279. vars := PMap.add (-v.v_id) (a,b,(s,e,t) :: fields,c,d) !vars
  1280. in
  1281. let cancel v =
  1282. v.v_id <- -v.v_id;
  1283. (* error if the constructor is extern *)
  1284. (match PMap.find v.v_id !vars with
  1285. | _,_,_,true,p ->
  1286. display_error ctx "Extern constructor could not be inlined" p;
  1287. error "Variable is used here" e.epos
  1288. | _ -> ());
  1289. vars := PMap.remove v.v_id !vars;
  1290. in
  1291. let rec skip_to_var e = match e.eexpr with
  1292. | TLocal v when v.v_id < 0 -> Some v
  1293. (* | TCast(e1,None) | TMeta(_,e1) | TParenthesis(e1) -> skip_to_var e1 *)
  1294. | _ -> None
  1295. in
  1296. let rec find_locals e =
  1297. match e.eexpr with
  1298. | TVar (v,eo) ->
  1299. Type.iter find_locals e;
  1300. begin match eo with
  1301. | Some n ->
  1302. begin match get_inline_ctor_info n with
  1303. | IKCtor (f,cst,c,tl,pl,el_init) when type_iseq v.v_type n.etype ->
  1304. (* inline the constructor *)
  1305. (match (try type_inline ctx cst f (mk (TLocal v) (TInst (c,tl)) n.epos) pl ctx.t.tvoid None n.epos true with Error (Custom _,_) -> None) with
  1306. | None -> ()
  1307. | Some ecst ->
  1308. let assigns = ref [] in
  1309. (* add field inits here because the filter has not run yet (issue #2336) *)
  1310. List.iter (fun cf -> match cf.cf_kind,cf.cf_expr with
  1311. | Var _,Some e -> assigns := (cf.cf_name,e,cf.cf_type) :: !assigns
  1312. | _ -> ()
  1313. ) c.cl_ordered_fields;
  1314. (* make sure we only have v.field = expr calls *)
  1315. let rec get_assigns e =
  1316. match e.eexpr with
  1317. | TBlock el ->
  1318. List.iter get_assigns el
  1319. | TBinop (OpAssign, { eexpr = TField ({ eexpr = TLocal vv },FInstance(_,_,cf)); etype = t }, e) when v == vv ->
  1320. assigns := (cf.cf_name,e,t) :: !assigns
  1321. | _ ->
  1322. raise Exit
  1323. in
  1324. try
  1325. get_assigns ecst;
  1326. (* mark variable as candidate for inlining *)
  1327. vars := PMap.add v.v_id (v,el_init,List.rev !assigns,c.cl_extern || Meta.has Meta.Extern cst.cf_meta,n.epos) !vars;
  1328. v.v_id <- -v.v_id; (* mark *)
  1329. (* recurse with the constructor code which will be inlined here *)
  1330. find_locals ecst
  1331. with Exit ->
  1332. ())
  1333. | IKArray (el,t) ->
  1334. vars := PMap.add v.v_id (v,[],ExtList.List.mapi (fun i e -> string_of_int i,e,t) el, false, n.epos) !vars;
  1335. v.v_id <- -v.v_id;
  1336. | IKStructure fl ->
  1337. vars := PMap.add v.v_id (v,[],List.map (fun (s,e) -> s,e,e.etype) fl, false, n.epos) !vars;
  1338. v.v_id <- -v.v_id;
  1339. | _ ->
  1340. ()
  1341. end
  1342. | _ -> ()
  1343. end
  1344. | TField(e1, (FInstance(_, _, {cf_kind = Var _; cf_name = s}) | FAnon({cf_kind = Var _; cf_name = s}))) ->
  1345. (match skip_to_var e1 with None -> find_locals e1 | Some _ -> ())
  1346. | TArray (e1,{eexpr = TConst (TInt i)}) ->
  1347. begin match skip_to_var e1 with
  1348. | None -> find_locals e1
  1349. | Some v ->
  1350. let (_,_,fields,_,_) = PMap.find (-v.v_id) !vars in
  1351. let i = Int32.to_int i in
  1352. if i < 0 || i >= List.length fields then cancel v
  1353. end
  1354. | TBinop((OpAssign | OpAssignOp _),e1,e2) ->
  1355. begin match e1.eexpr with
  1356. | TArray ({eexpr = TLocal v},{eexpr = TConst (TInt i)}) when v.v_id < 0 ->
  1357. check_field v (Int32.to_string i) e2 e2.etype
  1358. | TField({eexpr = TLocal v}, (FInstance(_, _, {cf_kind = Var _; cf_name = s}) | FAnon({cf_kind = Var _; cf_name = s}))) when v.v_id < 0 ->
  1359. check_field v s e2 e2.etype
  1360. | _ ->
  1361. find_locals e1
  1362. end;
  1363. find_locals e2
  1364. | TLocal v when v.v_id < 0 ->
  1365. cancel v
  1366. | _ ->
  1367. Type.iter find_locals e
  1368. in
  1369. find_locals e;
  1370. let vars = !vars in
  1371. if PMap.is_empty vars then
  1372. e
  1373. else begin
  1374. let vfields = PMap.map (fun (v,el_init,assigns,_,_) ->
  1375. (List.fold_left (fun (acc,map) (name,e,t) ->
  1376. let vf = alloc_var (v.v_name ^ "_" ^ name) t in
  1377. ((vf,e) :: acc, PMap.add name vf map)
  1378. ) ([],PMap.empty) assigns),el_init
  1379. ) vars in
  1380. let el_b = ref [] in
  1381. let append e = el_b := e :: !el_b in
  1382. let inline_field c cf v =
  1383. let (_, vars),el_init = PMap.find (-v.v_id) vfields in
  1384. (try
  1385. let v = PMap.find cf.cf_name vars in
  1386. mk (TLocal v) v.v_type e.epos
  1387. with Not_found ->
  1388. if (c.cl_path = ([],"Array") && cf.cf_name = "length") then begin
  1389. (* this can only occur for inlined array declarations, so we can use the statically known length here (issue #2568)*)
  1390. let l = PMap.fold (fun _ i -> i + 1) vars 0 in
  1391. mk (TConst (TInt (Int32.of_int l))) ctx.t.tint e.epos
  1392. end else
  1393. (* the variable was not set in the constructor, assume null *)
  1394. mk (TConst TNull) e.etype e.epos)
  1395. in
  1396. let inline_anon_field cf v =
  1397. let (_, vars),_ = PMap.find (-v.v_id) vfields in
  1398. (try
  1399. let v = PMap.find cf.cf_name vars in
  1400. mk (TLocal v) v.v_type e.epos
  1401. with Not_found ->
  1402. (* this could happen in untyped code, assume null *)
  1403. mk (TConst TNull) e.etype e.epos)
  1404. in
  1405. let inline_array_access i v =
  1406. let (_, vars),_ = PMap.find (-v.v_id) vfields in
  1407. (try
  1408. let v = PMap.find (Int32.to_string i) vars in
  1409. mk (TLocal v) v.v_type e.epos
  1410. with Not_found ->
  1411. (* probably out-of-bounds, assume null *)
  1412. mk (TConst TNull) e.etype e.epos)
  1413. in
  1414. let rec subst e =
  1415. match e.eexpr with
  1416. | TBlock el ->
  1417. let old = !el_b in
  1418. el_b := [];
  1419. List.iter (fun e -> append (subst e)) el;
  1420. let n = !el_b in
  1421. el_b := old;
  1422. {e with eexpr = TBlock (List.rev n)}
  1423. | TVar (v,Some e) when v.v_id < 0 ->
  1424. let (vars, _),el_init = PMap.find (-v.v_id) vfields in
  1425. List.iter (fun e ->
  1426. append (subst e)
  1427. ) el_init;
  1428. let (v_first,e_first),vars = match vars with
  1429. | v :: vl -> v,vl
  1430. | [] -> assert false
  1431. in
  1432. List.iter (fun (v,e) -> append (mk (TVar(v,Some (subst e))) ctx.t.tvoid e.epos)) (List.rev vars);
  1433. mk (TVar (v_first, Some (subst e_first))) ctx.t.tvoid e.epos
  1434. | TField (e1,FInstance (c,_,cf)) ->
  1435. begin match skip_to_var e1 with
  1436. | None -> Type.map_expr subst e
  1437. | Some v -> inline_field c cf v
  1438. end
  1439. | TArray (e1,{eexpr = TConst (TInt i)}) ->
  1440. begin match skip_to_var e1 with
  1441. | None -> Type.map_expr subst e
  1442. | Some v -> inline_array_access i v
  1443. end
  1444. | TField (e1,FAnon(cf)) ->
  1445. begin match skip_to_var e1 with
  1446. | None -> Type.map_expr subst e
  1447. | Some v -> inline_anon_field cf v
  1448. end
  1449. | _ ->
  1450. Type.map_expr subst e
  1451. in
  1452. let e = (try subst e with Not_found -> assert false) in
  1453. PMap.iter (fun _ (v,_,_,_,_) -> v.v_id <- -v.v_id) vars;
  1454. e
  1455. end
  1456. (* ---------------------------------------------------------------------- *)
  1457. (* COMPLETION *)
  1458. exception Return of Ast.expr
  1459. type compl_locals = {
  1460. mutable r : (string, (complex_type option * (int * Ast.expr * compl_locals) option)) PMap.t;
  1461. }
  1462. let optimize_completion_expr e =
  1463. let iid = ref 0 in
  1464. let typing_side_effect = ref false in
  1465. let locals : compl_locals = { r = PMap.empty } in
  1466. let save() = let old = locals.r in (fun() -> locals.r <- old) in
  1467. let get_local n = PMap.find n locals.r in
  1468. let maybe_typed e =
  1469. match fst e with
  1470. | EConst (Ident "null") -> false
  1471. | _ -> true
  1472. in
  1473. let decl n t e =
  1474. typing_side_effect := true;
  1475. locals.r <- PMap.add n (t,(match e with Some e when maybe_typed e -> incr iid; Some (!iid,e,{ r = locals.r }) | _ -> None)) locals.r
  1476. in
  1477. let rec loop e =
  1478. let p = snd e in
  1479. match fst e with
  1480. | EConst (Ident n) ->
  1481. (try
  1482. (match get_local n with
  1483. | Some _ , _ -> ()
  1484. | _ -> typing_side_effect := true)
  1485. with Not_found ->
  1486. ());
  1487. e
  1488. | EBinop (OpAssign,(EConst (Ident n),_),esub) ->
  1489. (try
  1490. (match get_local n with
  1491. | None, None when maybe_typed esub -> decl n None (Some esub)
  1492. | _ -> ())
  1493. with Not_found ->
  1494. ());
  1495. map e
  1496. | EVars vl ->
  1497. let vl = List.map (fun (v,t,e) ->
  1498. let e = (match e with None -> None | Some e -> Some (loop e)) in
  1499. decl v t e;
  1500. (v,t,e)
  1501. ) vl in
  1502. (EVars vl,p)
  1503. | EBlock el ->
  1504. let old = save() in
  1505. let told = ref (!typing_side_effect) in
  1506. let el = List.fold_left (fun acc e ->
  1507. typing_side_effect := false;
  1508. let e = loop e in
  1509. if !typing_side_effect then begin told := true; e :: acc end else acc
  1510. ) [] el in
  1511. old();
  1512. typing_side_effect := !told;
  1513. (EBlock (List.rev el),p)
  1514. | EFunction (v,f) ->
  1515. (match v with
  1516. | None -> ()
  1517. | Some name ->
  1518. decl name None (Some e));
  1519. let old = save() in
  1520. List.iter (fun (n,_,t,e) -> decl n t e) f.f_args;
  1521. let e = map e in
  1522. old();
  1523. e
  1524. | EFor ((EIn ((EConst (Ident n),_) as id,it),p),efor) ->
  1525. let it = loop it in
  1526. let old = save() in
  1527. let etmp = (EConst (Ident "$tmp"),p) in
  1528. decl n None (Some (EBlock [
  1529. (EVars ["$tmp",None,None],p);
  1530. (EFor ((EIn (id,it),p),(EBinop (OpAssign,etmp,(EConst (Ident n),p)),p)),p);
  1531. etmp
  1532. ],p));
  1533. let efor = loop efor in
  1534. old();
  1535. (EFor ((EIn (id,it),p),efor),p)
  1536. | EReturn _ ->
  1537. typing_side_effect := true;
  1538. map e
  1539. | ESwitch (e,cases,def) ->
  1540. let e = loop e in
  1541. let cases = List.map (fun (el,eg,eo) -> match eo with
  1542. | None ->
  1543. el,eg,eo
  1544. | Some e ->
  1545. let el = List.map loop el in
  1546. let old = save() in
  1547. List.iter (fun e ->
  1548. match fst e with
  1549. | ECall (_,pl) ->
  1550. List.iter (fun p ->
  1551. match fst p with
  1552. | EConst (Ident i) -> decl i None None (* sadly *)
  1553. | _ -> ()
  1554. ) pl
  1555. | _ -> ()
  1556. ) el;
  1557. let e = loop e in
  1558. old();
  1559. el, eg, Some e
  1560. ) cases in
  1561. let def = match def with
  1562. | None -> None
  1563. | Some None -> Some None
  1564. | Some (Some e) -> Some (Some (loop e))
  1565. in
  1566. (ESwitch (e,cases,def),p)
  1567. | ETry (et,cl) ->
  1568. let et = loop et in
  1569. let cl = List.map (fun (n,t,e) ->
  1570. let old = save() in
  1571. decl n (Some t) None;
  1572. let e = loop e in
  1573. old();
  1574. n, t, e
  1575. ) cl in
  1576. (ETry (et,cl),p)
  1577. | EDisplay (s,call) ->
  1578. typing_side_effect := true;
  1579. let tmp_locals = ref [] in
  1580. let tmp_hlocals = ref PMap.empty in
  1581. let rec subst_locals locals e =
  1582. match fst e with
  1583. | EConst (Ident n) ->
  1584. let p = snd e in
  1585. (try
  1586. (match PMap.find n locals.r with
  1587. | Some t , _ -> (ECheckType ((EConst (Ident "null"),p),t),p)
  1588. | _, Some (id,e,lc) ->
  1589. let name = (try
  1590. PMap.find id (!tmp_hlocals)
  1591. with Not_found ->
  1592. let e = subst_locals lc e in
  1593. let name = "$tmp_" ^ string_of_int id in
  1594. tmp_locals := (name,None,Some e) :: !tmp_locals;
  1595. tmp_hlocals := PMap.add id name !tmp_hlocals;
  1596. name
  1597. ) in
  1598. (EConst (Ident name),p)
  1599. | None, None ->
  1600. (* we can't replace the var *)
  1601. raise Exit)
  1602. with Not_found ->
  1603. (* not found locals are most likely to be member/static vars *)
  1604. e)
  1605. | EFunction (_,f) ->
  1606. Ast.map_expr (subst_locals { r = PMap.foldi (fun n i acc -> if List.exists (fun (a,_,_,_) -> a = n) f.f_args then acc else PMap.add n i acc) locals.r PMap.empty }) e
  1607. | EObjectDecl [] ->
  1608. (* this probably comes from { | completion so we need some context} *)
  1609. raise Exit
  1610. | _ ->
  1611. Ast.map_expr (subst_locals locals) e
  1612. in
  1613. (try
  1614. let e = subst_locals locals s in
  1615. let e = (EBlock [(EVars (List.rev !tmp_locals),p);(EDisplay (e,call),p)],p) in
  1616. raise (Return e)
  1617. with Exit ->
  1618. map e)
  1619. | EDisplayNew _ ->
  1620. raise (Return e)
  1621. | _ ->
  1622. map e
  1623. and map e =
  1624. Ast.map_expr loop e
  1625. in
  1626. (try loop e with Return e -> e)
  1627. (* ---------------------------------------------------------------------- *)