](http://haxe.org) - [The Cross-Platform Toolkit](http://haxe.org)
+[](https://travis-ci.org/HaxeFoundation/haxe)
+[](https://ci.appveyor.com/project/HaxeFoundation/haxe)
+[](https://saucelabs.com/u/haxe)
+[](https://gitter.im/HaxeFoundation/haxe?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge)
+
+Haxe is an open source toolkit that allows you to easily build cross-platform tools and applications that target many mainstream platforms. The Haxe toolkit includes:
+
+ * **The Haxe programming language**, a modern, high-level, strictly-typed programming language
+ * **The Haxe cross-compiler**, a state-of-the-art, lightning-speed compiler for many targets
+ * **The Haxe standard library**, a complete, cross-platform library of common functionality
+
+Haxe allows you to compile for the following targets:
+
+ * ActionScript 3
+ * C++
+ * C#
+ * Flash
+ * Java
+ * JavaScript
+ * NekoVM
+ * PHP
+ * Python
+
+You can try Haxe directly from your browser at [try.haxe.org](http://try.haxe.org)!
+
+For more information about Haxe, head to the [offical Haxe website](http://haxe.org).
+
+## License
+
+The Haxe project has several licenses, covering different parts of the projects.
+
+ * The Haxe compiler is released under the GNU General Public License version 2 or any later version.
+ * The Haxe libraries are released under a "two-clause" BSD license.
+ * The Neko runtime is licensed under the GNU Lesser General Public License version 2.1 or any later version.
+
+For the complete Haxe licenses, please see http://haxe.org/foundation/open-source.html or [extra/LICENSE.txt](extra/LICENSE.txt).
+
+## Installing Haxe
+
+The latest stable release is [Haxe 3.2.0-rc2](http://haxe.org/download/version/3.2.0-rc.2/). Pre-built binaries are available for your platform:
+
+ * **[Windows installer](http://haxe.org/download/file/3.2.0-rc.2/haxe-3.2.0-rc2-win.exe)**
+ * **[Windows binaries](http://haxe.org/download/file/3.2.0-rc.2/haxe-3.2.0-rc2-win.zip)**
+ * **[OSX installer](http://haxe.org/download/file/3.2.0-rc.2/haxe-3.2.0-rc2-osx-installer.pkg)**
+ * **[OSX binaries](http://haxe.org/download/file/3.2.0-rc.2/haxe-3.2.0-rc2-osx.tar.gz)**
+ * **[Linux 32-bit binaries](http://haxe.org/download/file/3.2.0-rc.2/haxe-3.2.0-rc2-linux32.tar.gz)**
+ * **[Linux 64-bit binaries](http://haxe.org/download/file/3.2.0-rc.2/haxe-3.2.0-rc2-linux64.tar.gz)**
+
+Automated development builds are available from [build.haxe.org](http://build.haxe.org).
+
+## Building from source
+
+ 1. Clone the repository using git. Be sure to initialize and fetch the submodules.
+
+ git clone --recursive git://github.com/HaxeFoundation/haxe.git
+ cd haxe
+
+ 2. Follow the [documentation on building Haxe for your platform](http://haxe.org/documentation/introduction/building-haxe.html).
+
+## Using Haxe
+
+For information on on using Haxe, consult the [Haxe documentation](http://haxe.org/documentation):
+
+ * [Haxe Introduction](http://haxe.org/documentation/introduction), an introduction to the Haxe toolkit
+ * [The Haxe Manual](http://haxe.org/manual), the reference manual for the Haxe language
+ * [Haxe API](http://api.haxe.org), documentation for the Haxe standard and native APIs
+ * [Haxelib](http://lib.haxe.org), a repository of Haxe libraries for a variety of needs
+
+## Community
+
+You can get help and talk with fellow Haxers from around the world via:
+
+ * the [official Haxe Google Group](https://groups.google.com/forum/#!forum/haxelang)
+ * the [Haxe IRC chatroom](http://unic0rn.github.io/tiramisu/haxe), #haxe on chat.freenode.net
+
+## Version compatibility
+
+Haxe | neko
+---- | -----
+2.* | 1.*
+3.0.0 | 2.0.0
+3.1.3 | 2.0.0
diff --git a/analyzer.ml b/analyzer.ml
new file mode 100644
index 0000000000000000000000000000000000000000..e5933e37734879a422a8c014f66f6e10e4524194
--- /dev/null
+++ b/analyzer.ml
@@ -0,0 +1,1667 @@
+open Ast
+open Type
+open Common
+open Typecore
+
+let s_expr = s_expr (s_type (print_context()))
+let s_expr_pretty = s_expr_pretty "" (s_type (print_context()))
+let debug e = print_endline (s_expr e)
+let debug_pretty s e = Printf.printf "%s %s\n" s (s_expr_pretty e)
+
+let flag_no_check = "no_check"
+let flag_check = "check"
+let flag_no_const_propagation = "no_const_propagation"
+let flag_const_propagation = "const_propagation"
+let flag_no_local_dce = "no_local_dce"
+let flag_local_dce = "local_dce"
+let flag_ignore = "ignore"
+let flag_no_simplification = "no_simplification"
+let flag_check_has_effect = "check_has_effect"
+let flag_no_check_has_effect = "no_check_has_effect"
+
+let has_analyzer_option meta s =
+ try
+ let rec loop ml = match ml with
+ | (Meta.Analyzer,el,_) :: ml ->
+ if List.exists (fun (e,p) ->
+ match e with
+ | EConst(Ident s2) when s = s2 -> true
+ | _ -> false
+ ) el then
+ true
+ else
+ loop ml
+ | _ :: ml ->
+ loop ml
+ | [] ->
+ false
+ in
+ loop meta
+ with Not_found ->
+ false
+
+let is_ignored meta =
+ try
+ let rec loop ml = match ml with
+ | (Meta.Analyzer,el,_) :: ml ->
+ if List.exists (fun (e,p) ->
+ match e with
+ | EConst(Ident s2) when flag_ignore = s2 -> true
+ | _ -> false
+ ) el then
+ true
+ else
+ loop ml
+ | (Meta.HasUntyped,_,_) :: _ ->
+ true
+ | _ :: ml ->
+ loop ml
+ | [] ->
+ false
+ in
+ loop meta
+ with Not_found ->
+ false
+
+let rec get_type_meta t = match t with
+ | TMono r ->
+ begin match !r with
+ | None -> raise Not_found
+ | Some t -> get_type_meta t
+ end
+ | TLazy f ->
+ get_type_meta (!f())
+ | TInst(c,_) ->
+ c.cl_meta
+ | TEnum(en,_) ->
+ en.e_meta
+ | TAbstract(a,_) ->
+ a.a_meta
+ | TType(t,_) ->
+ t.t_meta
+ | TAnon _ | TFun _ | TDynamic _ ->
+ raise Not_found
+
+let type_has_analyzer_option t s =
+ try
+ has_analyzer_option (get_type_meta t) s
+ with Not_found ->
+ false
+
+let is_enum_type t = match follow t with
+ | TEnum(_) -> true
+ | _ -> false
+
+let rec awkward_get_enum_index com e = match e.eexpr with
+ | TArray(e1,{eexpr = TConst(TInt i)}) when com.platform = Js && Int32.to_int i = 1 && is_enum_type e1.etype ->
+ e1
+ | TCall({eexpr = TField(e1, FDynamic "__Index")},[]) when com.platform = Cpp && is_enum_type e1.etype ->
+ e1
+ | TField(e1,FDynamic "index") when com.platform = Neko && is_enum_type e1.etype ->
+ e1
+ | TParenthesis e1 | TCast(e1,None) | TMeta(_,e1) ->
+ awkward_get_enum_index com e1
+ | _ ->
+ raise Not_found
+
+(*
+ This module simplifies the AST by introducing temporary variables for complex expressions in many places.
+ In particular, it ensures that no branching can occur in value-places so that we can later insert SSA PHI
+ nodes without worrying about their placement.
+*)
+module Simplifier = struct
+ let mk_block_context com =
+ let block_el = ref [] in
+ let push e = block_el := e :: !block_el in
+ let assign ev e =
+ let mk_assign e2 = match e2.eexpr with
+ | TBreak | TContinue | TThrow _ | TReturn _ -> e2
+ | _ -> mk (TBinop(OpAssign,ev,e2)) e2.etype e2.epos
+ in
+ let rec loop e = match e.eexpr with
+ | TBlock el ->
+ begin match List.rev el with
+ | e1 :: el ->
+ let el = List.rev ((loop e1) :: el) in
+ {e with eexpr = TBlock el}
+ | _ ->
+ mk_assign e
+ end
+ | TIf(e1,e2,eo) ->
+ let e2 = loop e2 in
+ let eo = match eo with None -> None | Some e3 -> Some (loop e3) in
+ {e with eexpr = TIf(e1,e2,eo)}
+ | TSwitch(e1,cases,edef) ->
+ let cases = List.map (fun (el,e) ->
+ let e = loop e in
+ el,e
+ ) cases in
+ let edef = match edef with None -> None | Some edef -> Some (loop edef) in
+ {e with eexpr = TSwitch(e1,cases,edef)}
+ | TTry(e1,catches) ->
+ let e1 = loop e1 in
+ let catches = List.map (fun (v,e) ->
+ let e = loop e in
+ v,e
+ ) catches in
+ {e with eexpr = TTry(e1,catches)}
+ | TParenthesis e1 | TMeta(_,e1) ->
+ loop e1 (* this is still weird, have to review *)
+(* | TBinop(OpAssign,({eexpr = TLocal _} as e1),e2) ->
+ push e;
+ mk_assign e1 *)
+(* | TBinop(OpAssignOp op,({eexpr = TLocal _} as e1),e2) ->
+ push e;
+ mk_assign e1 *)
+ | _ ->
+ mk_assign e
+ in
+ loop e
+ in
+ let declare_temp t eo p =
+ let v = alloc_var "tmp" t in
+ v.v_meta <- [Meta.CompilerGenerated,[],p];
+ let e_v = mk (TLocal v) t p in
+ let declare e_init =
+ let e = mk (TVar (v,e_init)) com.basic.tvoid p in
+ push e;
+ in
+ let e_v = match eo with
+ | None ->
+ declare None;
+ e_v
+ | Some e1 ->
+ begin match e1.eexpr with
+ | TThrow _ | TReturn _ | TBreak | TContinue ->
+ e1
+ | _ ->
+ let rec loop e_v e = match e.eexpr with
+ | TParenthesis e1 ->
+ loop {e_v with eexpr = TParenthesis e_v} e1
+ | TMeta(m,e1) ->
+ loop {e_v with eexpr = TMeta(m,e_v)} e1
+ | _ ->
+ e_v,e
+ in
+ let e_v',e1 = loop e_v e1 in
+ let e1 = assign e_v e1 in
+ begin match e1.eexpr with
+ | TBinop(OpAssign,{eexpr = TLocal v1},e2) when v == v1 ->
+ declare (Some e2)
+ | _ ->
+ declare None;
+ push e1
+ end;
+ e_v'
+ end
+ in
+ e_v
+ in
+ let rec push_block () =
+ let cur = !block_el in
+ block_el := [];
+ fun () ->
+ let added = !block_el in
+ block_el := cur;
+ List.rev added
+ and block f el =
+ let close = push_block() in
+ List.iter (fun e ->
+ push (f e)
+ ) el;
+ close()
+ in
+ block,declare_temp,fun () -> !block_el
+
+ let apply com e =
+ let block,declare_temp,close_block = mk_block_context com in
+ let skip_binding ?(allow_tlocal=false) e =
+ let rec loop e =
+ match e.eexpr with
+ | TConst _ | TTypeExpr _ | TFunction _ -> ()
+ | TLocal _ when allow_tlocal -> ()
+ | TParenthesis e1 | TCast(e1,None) -> Type.iter loop e
+ | TField(_,(FStatic(c,cf) | FInstance(c,_,cf))) when has_analyzer_option cf.cf_meta flag_no_simplification || has_analyzer_option c.cl_meta flag_no_simplification -> ()
+ | TField({eexpr = TLocal _},_) when allow_tlocal -> ()
+ | TCall({eexpr = TField(_,(FStatic(c,cf) | FInstance(c,_,cf)))},el) when has_analyzer_option cf.cf_meta flag_no_simplification || has_analyzer_option c.cl_meta flag_no_simplification -> ()
+ | TCall({eexpr = TLocal { v_name = "__cpp__" } },_) -> ()
+ | TField(_,FEnum _) -> ()
+ | TField(_,FDynamic _) -> ()
+ | _ when (try ignore(awkward_get_enum_index com e); true with Not_found -> false) -> ()
+ | _ -> raise Exit
+ in
+ try
+ loop e;
+ true
+ with Exit ->
+ begin match follow e.etype with
+ | TAbstract({a_path = [],"Void"},_) -> true
+ | TInst ({ cl_path = [],"Array" }, _) when com.platform = Cpp -> true
+ | _ -> false
+ end
+ in
+ let has_unbound = ref false in
+ let rec loop e = match e.eexpr with
+ | TCall({eexpr = TLocal v | TField({eexpr = TLocal v},_)},_) | TField({eexpr = TLocal v},_) | TLocal v when Meta.has Meta.Unbound v.v_meta && v.v_name <> "`trace" ->
+ has_unbound := true;
+ e
+ | TBlock el ->
+ {e with eexpr = TBlock (block loop el)}
+ | TCall({eexpr = TField(_,(FStatic(c,cf) | FInstance(c,_,cf)))},el) when has_analyzer_option cf.cf_meta flag_no_simplification || has_analyzer_option c.cl_meta flag_no_simplification ->
+ e
+ | TField(_,(FStatic(c,cf) | FInstance(c,_,cf))) when has_analyzer_option cf.cf_meta flag_no_simplification || has_analyzer_option c.cl_meta flag_no_simplification ->
+ e
+ | TCall(e1,el) ->
+ let rec is_valid_call_target e = match e.eexpr with
+ | TFunction _ | TField _ | TLocal _ | TConst (TSuper) ->
+ true
+ | TParenthesis e1 | TCast(e1,None) | TMeta(_,e1) ->
+ is_valid_call_target e1
+ | _ ->
+ false
+ in
+ let e1 = if is_valid_call_target e1 then
+ loop e1
+ else
+ bind e1
+ in
+ let check e t =
+ if type_has_analyzer_option t flag_no_simplification then e
+ else bind e
+ in
+ let el = match e1.eexpr,follow e1.etype with
+ | TConst TSuper,_ when com.platform = Java || com.platform = Cs ->
+ (* they hate you if you mess up the super call *)
+ el
+ | _,TFun _ | TConst TSuper,_ ->
+ Codegen.UnificationCallback.check_call check el e1.etype
+ | _ ->
+ (* too dangerous *)
+ List.map loop el
+ in
+ {e with eexpr = TCall(e1,el)}
+ | TNew(c,tl,el) ->
+ {e with eexpr = TNew(c,tl,ordered_list el)}
+ | TArrayDecl el ->
+ {e with eexpr = TArrayDecl (ordered_list el)}
+ | TObjectDecl fl ->
+ let el = ordered_list (List.map snd fl) in
+ {e with eexpr = TObjectDecl (List.map2 (fun (n,_) e -> n,e) fl el)}
+ | TBinop(OpBoolAnd | OpBoolOr as op,e1,e2) ->
+ let e1 = loop e1 in
+ let e_then = mk (TBlock (block loop [e2])) e2.etype e2.epos in
+ let e_if,e_else = if op = OpBoolOr then
+ mk (TUnop(Not,Prefix,e1)) com.basic.tbool e.epos,mk (TConst (TBool(true))) com.basic.tbool e.epos
+ else
+ e1,mk (TConst (TBool(false))) com.basic.tbool e.epos
+ in
+ loop (mk (TIf(e_if,e_then,Some e_else)) com.basic.tbool e.epos)
+ | TBinop((OpAssign | OpAssignOp _) as op,{eexpr = TArray(e11,e12)},e2) ->
+ let e1 = match ordered_list [e11;e12] with
+ | [e1;e2] ->
+ {e with eexpr = TArray(e1,e2)}
+ | _ ->
+ assert false
+ in
+ let e2 = bind e2 in
+ {e with eexpr = TBinop(op,e1,e2)}
+ | TBinop((OpAssign | OpAssignOp _) as op,e1,e2) ->
+ let e2 = bind ~allow_tlocal:true e2 in
+ let e1 = loop e1 in
+ {e with eexpr = TBinop(op,e1,e2)}
+ | TBinop(op,e1,e2) ->
+ begin match ordered_list [e1;e2] with
+ | [e1;e2] ->
+ {e with eexpr = TBinop(op,e1,e2)}
+ | _ ->
+ assert false
+ end
+ | TArray(e1,e2) ->
+ begin match ordered_list [e1;e2] with
+ | [e1;e2] ->
+ {e with eexpr = TArray(e1,e2)}
+ | _ ->
+ assert false
+ end
+ | TWhile(e1,e2,flag) when (match e1.eexpr with TConst(TBool true) | TParenthesis {eexpr = TConst(TBool true)} -> false | _ -> true) ->
+ let p = e.epos in
+ let e_break = mk TBreak t_dynamic p in
+ let e_not = mk (TUnop(Not,Prefix,Codegen.mk_parent e1)) e1.etype e1.epos in
+ let e_if eo = mk (TIf(e_not,e_break,eo)) com.basic.tvoid p in
+ let rec map_continue e = match e.eexpr with
+ | TContinue ->
+ (e_if (Some e))
+ | TWhile _ | TFor _ ->
+ e
+ | _ ->
+ Type.map_expr map_continue e
+ in
+ let e2 = if flag = NormalWhile then e2 else map_continue e2 in
+ let e_if = e_if None in
+ let e_if = mk (TMeta((Meta.Custom ":whileCond",[],e_if.epos), e_if)) e_if.etype e_if.epos in
+ let e_block = if flag = NormalWhile then Type.concat e_if e2 else Type.concat e2 e_if in
+ let e_true = mk (TConst (TBool true)) com.basic.tbool p in
+ let e = mk (TWhile(Codegen.mk_parent e_true,e_block,NormalWhile)) e.etype p in
+ loop e
+ | TFor(v,e1,e2) ->
+ let e1 = bind e1 in
+ let e2 = loop e2 in
+ {e with eexpr = TFor(v,e1,e2)}
+ | TIf(e1,e2,eo) ->
+ let e1 = bind e1 in
+ let e2 = loop e2 in
+ let eo = match eo with None -> None | Some e -> Some (loop e) in
+ {e with eexpr = TIf(e1,e2,eo)}
+ | TSwitch (e1,cases,eo) ->
+ let e1 = bind e1 in
+ let cases = List.map (fun (el,e) ->
+ let el = List.map loop el in
+ let e = loop e in
+ el,e
+ ) cases in
+ let eo = match eo with None -> None | Some e -> Some (loop e) in
+ {e with eexpr = TSwitch(e1,cases,eo)}
+ | TVar(v,Some e1) ->
+ let e1 = match e1.eexpr with
+ | TFunction _ -> loop e1
+ | TArrayDecl [{eexpr = TFunction _}] -> loop e1
+ | _ -> bind ~allow_tlocal:true e1
+ in
+ {e with eexpr = TVar(v,Some e1)}
+ | TUnop((Neg | NegBits | Not) as op,flag,e1) ->
+ let e1 = bind e1 in
+ {e with eexpr = TUnop(op,flag,e1)}
+ | TField(e1,fa) ->
+ let e1 = bind ~allow_tlocal:true e1 in
+ {e with eexpr = TField(e1,fa)}
+ | TReturn (Some ({eexpr = TThrow _ | TReturn _} as e1)) ->
+ loop e1 (* this is a bit hackish *)
+ | TReturn (Some e1) ->
+ let e1 = bind e1 in
+ {e with eexpr = TReturn (Some e1)}
+ | TThrow e1 ->
+ let e1 = bind e1 in
+ {e with eexpr = TThrow e1}
+ | TCast(e1,mto) ->
+ let e1 = bind ~allow_tlocal:true e1 in
+ {e with eexpr = TCast(e1,mto)}
+ | _ ->
+ Type.map_expr loop e
+ and bind ?(allow_tlocal=false) e =
+ let e = loop e in
+ if skip_binding ~allow_tlocal e then
+ e
+ else
+ declare_temp e.etype (Some e) e.epos
+ and ordered_list el =
+ if List.for_all (skip_binding ~allow_tlocal:true) el then
+ List.map loop el
+ else
+ List.map bind el
+ in
+ let e = loop e in
+ !has_unbound,match close_block() with
+ | [] ->
+ e
+ | el ->
+ mk (TBlock (List.rev (e :: el))) e.etype e.epos
+
+ let unapply com e =
+ let var_map = ref IntMap.empty in
+ let rec get_assignment_to v e = match e.eexpr with
+ | TBinop(OpAssign,{eexpr = TLocal v2},e2) when v == v2 -> Some e2
+ | TBlock [e] -> get_assignment_to v e
+ | TIf(e1,e2,Some e3) ->
+ begin match get_assignment_to v e2,get_assignment_to v e3 with
+ | Some e2,Some e3 -> Some ({e with eexpr = TIf(e1,e2,Some e3)})
+ | _ -> None
+ end
+ | _ -> None
+ in
+ let if_or_op e e1 e2 e3 = match e1.eexpr,e3.eexpr with
+ | TUnop(Not,Prefix,e1),TConst (TBool true) -> {e with eexpr = TBinop(OpBoolOr,e1,e2)}
+ | _,TConst (TBool false) -> {e with eexpr = TBinop(OpBoolAnd,e1,e2)}
+ | _ -> {e with eexpr = TIf(e1,e2,Some e3)}
+ in
+ let rec loop e = match e.eexpr with
+ | TBlock el ->
+ let rec loop2 el = match el with
+ | e :: el ->
+ begin match e.eexpr with
+ | TVar(v,Some e1) when Meta.has Meta.CompilerGenerated v.v_meta ->
+ if el = [] then
+ [loop e1]
+ else begin
+ var_map := IntMap.add v.v_id (loop e1) !var_map;
+ loop2 el
+ end
+ | TVar(v,None) when not (com.platform = Php) ->
+ begin match el with
+ | {eexpr = TBinop(OpAssign,{eexpr = TLocal v2},e2)} :: el when v == v2 ->
+ let e = {e with eexpr = TVar(v,Some e2)} in
+ loop2 (e :: el)
+ | ({eexpr = TIf(e1,e2,Some e3)} as e_if) :: el ->
+ let e1 = loop e1 in
+ let e2 = loop e2 in
+ let e3 = loop e3 in
+ begin match get_assignment_to v e2,get_assignment_to v e3 with
+ | Some e2,Some e3 ->
+ let e_if = if_or_op e_if (loop e1) (loop e2) (loop e3) in
+ let e = {e with eexpr = TVar(v,Some e_if)} in
+ loop2 (e :: el)
+ | _ ->
+ let e_if = {e_if with eexpr = TIf(e1,e2,Some e3)} in
+ e :: e_if :: loop2 el
+ end
+ | _ ->
+ let e = loop e in
+ e :: loop2 el
+ end
+ | TReturn (Some e1) when (match follow e1.etype with TAbstract({a_path=[],"Void"},_) -> true | _ -> false) ->
+ [(loop e1);{e with eexpr = TReturn None}]
+ | _ ->
+ let e = loop e in
+ e :: loop2 el
+ end
+ | [] ->
+ []
+ in
+ let el = loop2 el in
+ {e with eexpr = TBlock el}
+ | TLocal v when Meta.has Meta.CompilerGenerated v.v_meta ->
+ begin try IntMap.find v.v_id !var_map
+ with Not_found -> e end
+ | TWhile(e1,e2,flag) ->
+ let e1 = loop e1 in
+ let e2 = loop e2 in
+ let extract_cond e = match e.eexpr with
+ | TIf({eexpr = TUnop(Not,_,e1)},_,_) -> e1
+ | TBreak -> raise Exit (* can happen due to optimization, not so easy to deal with because there might be other breaks/continues *)
+ | _ -> assert false
+ in
+ let e1,e2,flag = try
+ begin match e2.eexpr with
+ | TBlock el ->
+ begin match el with
+ | {eexpr = TMeta((Meta.Custom ":whileCond",_,_),e1)} :: el ->
+ let e1 = extract_cond e1 in
+ e1,{e2 with eexpr = TBlock el},NormalWhile
+ | _ ->
+ e1,e2,flag
+ (* issue 3844 *)
+(* begin match List.rev el with
+ | {eexpr = TMeta((Meta.Custom ":whileCond",_,_),e1)} :: el ->
+ let e1 = extract_cond e1 in
+ e1,{e2 with eexpr = TBlock (List.rev el)},DoWhile
+ | _ ->
+ e1,e2,flag
+ end *)
+ end
+ | _ ->
+ e1,e2,flag
+ end with Exit ->
+ e1,e2,flag
+ in
+ {e with eexpr = TWhile(e1,e2,flag)}
+ | TIf(e1,e2,Some e3) ->
+ let e1 = loop e1 in
+ let e2 = loop e2 in
+ let e3 = loop e3 in
+ if_or_op e e1 e2 e3
+ | _ ->
+ Type.map_expr loop e
+ in
+ loop e
+end
+
+module Ssa = struct
+
+ type var_map = tvar IntMap.t
+
+ type condition =
+ | Equal of tvar * texpr
+ | NotEqual of tvar * texpr
+
+ type node_data = {
+ nd_pos: pos;
+ mutable nd_var_map : var_map;
+ mutable nd_terminates : bool;
+ }
+
+ type join_node = {
+ mutable branches : node_data list;
+ }
+
+ type ssa_context = {
+ com : Common.context;
+ mutable cleanup : (unit -> unit) list;
+ mutable cur_data : node_data;
+ mutable var_conds : (condition list) IntMap.t;
+ mutable loop_stack : (join_node * join_node) list;
+ mutable exception_stack : join_node list;
+ mutable block_depth : int;
+ }
+
+ let s_cond = function
+ | Equal(v,e) -> Printf.sprintf "%s == %s" v.v_name (s_expr_pretty e)
+ | NotEqual(v,e) -> Printf.sprintf "%s != %s" v.v_name (s_expr_pretty e)
+
+ let s_conds conds =
+ String.concat " && " (List.map s_cond conds)
+
+ let mk_loc v p = mk (TLocal v) v.v_type p
+
+ let mk_phi =
+ let v_phi = alloc_var "__ssa_phi__" t_dynamic in
+ (fun vl p ->
+ let e = mk (TCall(mk_loc v_phi p,(List.map (fun (v,p) -> mk_loc v p) vl))) t_dynamic p in
+ e
+ )
+
+ (* TODO: make sure this is conservative *)
+ let can_throw e =
+ let rec loop e = match e.eexpr with
+ | TConst _ | TLocal _ | TTypeExpr _ | TFunction _ | TBlock _ -> ()
+ | TCall _ | TNew _ | TThrow _ | TCast(_,Some _) -> raise Exit
+ | _ -> Type.iter loop e
+ in
+ try
+ loop e; false
+ with Exit ->
+ true
+
+ let mk_join_node() = {
+ branches = []
+ }
+
+ let mk_node_data p = {
+ nd_pos = p;
+ nd_var_map = IntMap.empty;
+ nd_terminates = false;
+ }
+
+ let add_branch join branch p =
+ join.branches <- {branch with nd_pos = p} :: join.branches
+
+ let branch ctx p =
+ let old_map = ctx.cur_data.nd_var_map in
+ let old_term = ctx.cur_data.nd_terminates in
+ ctx.cur_data.nd_terminates <- false;
+ (fun join ->
+ add_branch join ctx.cur_data p;
+ ctx.cur_data.nd_var_map <- old_map;
+ ctx.cur_data.nd_terminates <- old_term;
+ )
+
+ let terminate ctx =
+ ctx.cur_data.nd_terminates <- true
+
+ let set_loop_join ctx join_top join_bottom =
+ ctx.loop_stack <- (join_top,join_bottom) :: ctx.loop_stack;
+ (fun () ->
+ ctx.loop_stack <- List.tl ctx.loop_stack
+ )
+
+ let set_exception_join ctx join =
+ ctx.exception_stack <- join :: ctx.exception_stack;
+ (fun () ->
+ ctx.exception_stack <- List.tl ctx.exception_stack;
+ )
+
+ let create_v_extra v =
+ match v.v_extra with
+ | Some (_,Some _) ->
+ ()
+ | Some (tl,None) ->
+ let e_extra = mk (TObjectDecl []) t_dynamic null_pos in
+ v.v_extra <- Some (tl,Some e_extra)
+ | None ->
+ let e_extra = mk (TObjectDecl []) t_dynamic null_pos in
+ v.v_extra <- Some ([],Some e_extra)
+
+ let set_v_extra_value v s e = match v.v_extra with
+ | Some (tl, Some {eexpr = TObjectDecl fl}) ->
+ let rec loop fl = match fl with
+ | (s',_) :: fl when s' = s ->
+ (s,e) :: fl
+ | f1 :: fl ->
+ f1 :: loop fl
+ | [] ->
+ [s,e]
+ in
+ let e_extra = mk (TObjectDecl (loop fl)) t_dynamic null_pos in
+ v.v_extra <- Some (tl, Some e_extra)
+ | _ ->
+ assert false
+
+ let get_origin_var v = match v.v_extra with
+ | Some (_,Some {eexpr = TObjectDecl fl}) ->
+ begin match List.assoc "origin_var" fl with
+ | {eexpr = TLocal v'} -> v'
+ | _ -> raise Not_found
+ end
+ | _ ->
+ raise Not_found
+
+ let set_origin_var v v_origin p =
+ let ev = mk_loc v_origin p in
+ set_v_extra_value v "origin_var" ev
+
+ let get_var_value v = match v.v_extra with
+ | Some (_,Some {eexpr = TObjectDecl fl}) ->
+ List.assoc "var_value" fl
+ | _ ->
+ raise Not_found
+
+ let set_var_value v e =
+ set_v_extra_value v "var_value" e
+
+ let get_var_usage_count v = match v.v_extra with
+ | Some (_,Some {eexpr = TObjectDecl fl}) ->
+ begin try
+ begin match List.assoc "usage_count" fl with
+ | {eexpr = TConst (TInt i32)} -> Int32.to_int i32
+ | _ -> 0
+ end
+ with Not_found ->
+ 0
+ end
+ | _ ->
+ raise Not_found
+
+ let set_var_usage_count v i =
+ let e = mk (TConst (TInt (Int32.of_int i))) t_dynamic null_pos in
+ set_v_extra_value v "usage_count" e
+
+ let declare_var ctx v p =
+ let old = v.v_extra in
+ ctx.cleanup <- (fun () ->
+ v.v_extra <- old
+ ) :: ctx.cleanup;
+ ctx.cur_data.nd_var_map <- IntMap.add v.v_id v ctx.cur_data.nd_var_map;
+ v.v_meta <- ((Meta.Custom ":blockDepth",[EConst (Int (string_of_int ctx.block_depth)),p],p)) :: v.v_meta;
+ v.v_extra <- None;
+ create_v_extra v;
+ set_origin_var v v p
+
+ let assign_var ctx v e p =
+ if v.v_capture then
+ v
+ else begin
+ let i = match v.v_extra with
+ | Some (l,eo) ->
+ v.v_extra <- Some (("",t_dynamic) :: l,eo);
+ List.length l + 1
+ | _ ->
+ error "Something went wrong" p
+ in
+ let v' = alloc_var (Printf.sprintf "%s<%i>" v.v_name i) v.v_type in
+ create_v_extra v';
+ v'.v_meta <- [(Meta.Custom ":ssa"),[],p];
+ set_origin_var v' v p;
+ ctx.cur_data.nd_var_map <- IntMap.add v.v_id v' ctx.cur_data.nd_var_map;
+ set_var_value v' e;
+ v'
+ end
+
+ let get_var ctx v p =
+ try
+ IntMap.find v.v_id ctx.cur_data.nd_var_map
+ with Not_found ->
+ if not (has_meta Meta.Unbound v.v_meta) then
+ error (Printf.sprintf "Unbound variable %s" v.v_name) p;
+ v
+
+ let close_join_node ctx node p =
+ let terminates = ref true in
+ let branches = List.filter (fun branch ->
+ if branch.nd_terminates then false
+ else begin
+ terminates := false;
+ true
+ end
+ ) node.branches in
+ match branches with
+ | [] ->
+ ()
+ | branch :: branches ->
+ let vars = ref (IntMap.map (fun v -> [v,branch.nd_pos]) branch.nd_var_map) in
+ let rec handle_branch branch =
+ IntMap.iter (fun i v ->
+ try
+ let vl = IntMap.find i !vars in
+ if not (List.exists (fun (v',_) -> v == v') vl) then
+ vars := IntMap.add i ((v,p) :: vl) !vars
+ with Not_found ->
+ ()
+ ) branch.nd_var_map;
+ in
+ List.iter handle_branch branches;
+ ctx.cur_data.nd_terminates <- !terminates;
+ IntMap.iter (fun i vl -> match vl with
+ | [v,p] ->
+ ctx.cur_data.nd_var_map <- IntMap.add i v ctx.cur_data.nd_var_map;
+ | (v',_) :: _ ->
+ let v = get_origin_var v' in
+ ignore(assign_var ctx v (mk_phi vl p) p)
+ | _ ->
+ assert false
+ ) !vars
+
+ let invert_cond = function
+ | Equal(v,e) -> NotEqual(v,e)
+ | NotEqual(v,e) -> Equal(v,e)
+
+ let invert_conds =
+ List.map invert_cond
+
+ let rec eval_cond ctx e = match e.eexpr with
+ | TBinop(OpNotEq,{eexpr = TLocal v},e1) ->
+ [NotEqual(v,e1)]
+ | TBinop(OpEq,{eexpr = TLocal v},e1) ->
+ [Equal(v,e1)]
+ | TUnop(Not,_,e1) ->
+ invert_conds (eval_cond ctx e1)
+ | TLocal v ->
+ begin try eval_cond ctx (get_var_value v)
+ with Not_found -> [] end
+ | _ ->
+ []
+
+ let append_cond ctx v cond p =
+ begin try
+ let conds = IntMap.find v.v_id ctx.var_conds in
+ ctx.var_conds <- IntMap.add v.v_id (cond :: conds) ctx.var_conds
+ with Not_found ->
+ ctx.var_conds <- IntMap.add v.v_id [cond] ctx.var_conds
+ end
+
+(* let apply_cond ctx = function
+ | Equal({v_extra = Some(_,Some {eexpr = TLocal v})} as v0,e1) ->
+ let v' = assign_var ctx v (mk_loc v0 e1.epos) e1.epos in
+ append_cond ctx v' (Equal(v',e1)) e1.epos
+ | NotEqual({v_extra = Some(_,Some {eexpr = TLocal v})} as v0,e1) ->
+ let v' = assign_var ctx v (mk_loc v0 e1.epos) e1.epos in
+ append_cond ctx v' (NotEqual(v',e1)) e1.epos
+ | _ -> ()
+
+ let apply_not_null_cond ctx v p =
+ apply_cond ctx (NotEqual(v,(mk (TConst TNull) t_dynamic p))) *)
+
+ let apply com e =
+ let rec handle_if ctx f econd eif eelse =
+ let econd = loop ctx econd in
+ (* let cond = eval_cond ctx econd in *)
+ let join = mk_join_node() in
+ let close = branch ctx eif.epos in
+ (* List.iter (apply_cond ctx) cond; *)
+ let eif = loop ctx eif in
+ close join;
+ let eelse = match eelse with
+ | None ->
+ (* let cond = invert_conds cond in *)
+ (* List.iter (apply_cond ctx) cond; *)
+ add_branch join ctx.cur_data e.epos;
+ None
+ | Some e ->
+ let close = branch ctx e.epos in
+ (* let cond = invert_conds cond in *)
+ (* List.iter (apply_cond ctx) cond; *)
+ let eelse = loop ctx e in
+ close join;
+ Some eelse
+ in
+ close_join_node ctx join e.epos;
+ f econd eif eelse
+ and handle_loop_body ctx e =
+ let join_top = mk_join_node() in
+ let join_bottom = mk_join_node() in
+ let unset = set_loop_join ctx join_top join_bottom in
+ let close = branch ctx e.epos in
+ ignore(loop ctx e); (* TODO: I don't know if this is sane. *)
+ close join_top;
+ add_branch join_top ctx.cur_data e.epos;
+ close_join_node ctx join_top e.epos;
+ let ebody = loop ctx e in
+ ctx.cur_data.nd_terminates <- false;
+ unset();
+ close_join_node ctx join_bottom e.epos;
+ ebody
+ and loop ctx e = match e.eexpr with
+ (* var declarations *)
+ | TVar(v,eo) ->
+ declare_var ctx v e.epos;
+ let eo = match eo with
+ | None -> None
+ | Some e ->
+ let e = loop ctx e in
+ set_var_value v e;
+ Some e
+ in
+ {e with eexpr = TVar(v,eo)}
+ | TFunction tf ->
+ let close = branch ctx e.epos in
+ List.iter (fun (v,co) ->
+ declare_var ctx v e.epos;
+(* match co with
+ | Some TNull when (match v.v_type with TType({t_path=["haxe"],"PosInfos"},_) -> false | _ -> true) -> ()
+ | _ -> apply_not_null_cond ctx v e.epos *)
+ ) tf.tf_args;
+ let e' = loop ctx tf.tf_expr in
+ close (mk_join_node());
+ {e with eexpr = TFunction {tf with tf_expr = e'}}
+ (* var modifications *)
+ | TBinop(OpAssign,({eexpr = TLocal v} as e1),e2) when v.v_name <> "this" ->
+ let e2 = loop ctx e2 in
+ let _ = assign_var ctx v e2 e1.epos in
+ {e with eexpr = TBinop(OpAssign,e1,e2)}
+ | TBinop(OpAssignOp op,({eexpr = TLocal v} as e1),e2) ->
+ let e1 = loop ctx e1 in
+ let e2 = loop ctx e2 in
+ let e_op = mk (TBinop(op,e1,e2)) e.etype e.epos in
+ let _ = assign_var ctx v e_op e1.epos in
+ {e with eexpr = TBinop(OpAssignOp op,e1,e2)}
+ | TUnop((Increment | Decrement as op),flag,({eexpr = TLocal v} as e1)) ->
+ let op = match op with Increment -> OpAdd | Decrement -> OpSub | _ -> assert false in
+ let e_one = mk (TConst (TInt (Int32.of_int 1))) com.basic.tint e.epos in
+ let e1 = loop ctx e1 in
+ let e_op = mk (TBinop(op,e1,e_one)) e.etype e.epos in
+ let _ = assign_var ctx v e_op e1.epos in
+ e
+ (* var user *)
+ | TLocal v ->
+ let v = get_var ctx v e.epos in
+ {e with eexpr = TLocal v}
+ (* control flow *)
+ | TIf(econd,eif,eelse) ->
+ let f econd eif eelse = {e with eexpr = TIf(econd,eif,eelse)} in
+ handle_if ctx f econd eif eelse
+ | TSwitch(e1,cases,edef) ->
+ let e1 = loop ctx e1 in
+ let join = mk_join_node() in
+ let cases = List.map (fun (el,e) ->
+ let close = branch ctx e.epos in
+ let el = List.map (loop ctx) el in
+ let e = loop ctx e in
+ close join;
+ el,e
+ ) cases in
+ let edef = match edef with
+ | Some e ->
+ let close = branch ctx e.epos in
+ let e = loop ctx e in
+ close join;
+ Some e
+ | None ->
+ begin match e1.eexpr with
+ | TMeta((Meta.Exhaustive,_,_),_)
+ | TParenthesis({eexpr = TMeta((Meta.Exhaustive,_,_),_)}) ->
+ ()
+ | _ ->
+ add_branch join ctx.cur_data e.epos;
+ end;
+ None
+ in
+ close_join_node ctx join e.epos;
+ let e = {e with eexpr = TSwitch(e1,cases,edef)} in
+ e
+ | TWhile(econd,ebody,mode) ->
+ let econd = loop ctx econd in
+ let ebody = handle_loop_body ctx ebody in
+ let e = {e with eexpr = TWhile(econd,ebody,mode)} in
+ e
+ | TFor(v,e1,ebody) ->
+ declare_var ctx v e.epos;
+ (* apply_not_null_cond ctx v e1.epos; *)
+ let v' = IntMap.find v.v_id ctx.cur_data.nd_var_map in
+ let e1 = loop ctx e1 in
+ let ebody = handle_loop_body ctx ebody in
+ let e = {e with eexpr = TFor(v',e1,ebody)} in
+ e
+ | TTry(e1,catches) ->
+ let join_ex = mk_join_node() in
+ let join_bottom = mk_join_node() in
+ let unset = set_exception_join ctx join_ex in
+ let e1 = loop ctx e1 in
+ unset();
+ add_branch join_bottom ctx.cur_data e.epos;
+ close_join_node ctx join_ex e.epos;
+ let catches = List.map (fun (v,e) ->
+ declare_var ctx v e.epos;
+ (* apply_not_null_cond ctx v e.epos; *)
+ let close = branch ctx e.epos in
+ let e = loop ctx e in
+ close join_bottom;
+ v,e
+ ) catches in
+ close_join_node ctx join_bottom e.epos;
+ let e = {e with eexpr = TTry(e1,catches)} in
+ e
+ | TBreak ->
+ begin match ctx.loop_stack with
+ | [] -> error "Break outside loop" e.epos
+ | (_,join) :: _ -> add_branch join ctx.cur_data e.epos
+ end;
+ terminate ctx;
+ e
+ | TContinue ->
+ begin match ctx.loop_stack with
+ | [] -> error "Continue outside loop" e.epos
+ | (join,_) :: _ -> add_branch join ctx.cur_data e.epos
+ end;
+ terminate ctx;
+ e
+ | TThrow e1 ->
+ let e1 = loop ctx e1 in
+ begin match ctx.exception_stack with
+ | join :: _ -> add_branch join ctx.cur_data e.epos
+ | _ -> ()
+ end;
+ terminate ctx;
+ {e with eexpr = TThrow e1}
+ | TReturn eo ->
+ let eo = match eo with None -> None | Some e -> Some (loop ctx e) in
+ terminate ctx;
+ {e with eexpr = TReturn eo}
+ | TBlock el ->
+ let rec loop2 el = match el with
+ | [] ->
+ []
+ | e :: el ->
+ if ctx.cur_data.nd_terminates then begin
+ (* ctx.com.warning (Printf.sprintf "Unreachable code: %s" (s_expr_pretty e)) e.epos; *)
+ []
+ end else
+ let e = loop ctx e in
+ e :: (loop2 el)
+ in
+ ctx.block_depth <- ctx.block_depth + 1;
+ let el = loop2 el in
+ ctx.block_depth <- ctx.block_depth - 1;
+ {e with eexpr = TBlock(el)}
+ | _ ->
+ begin match ctx.exception_stack with
+ | join :: _ when can_throw e -> add_branch join ctx.cur_data e.epos
+ | _ -> ()
+ end;
+ Type.map_expr (loop ctx) e
+ in
+ let ctx = {
+ com = com;
+ cur_data = mk_node_data e.epos;
+ var_conds = IntMap.empty;
+ loop_stack = [];
+ exception_stack = [];
+ cleanup = [];
+ block_depth = 0;
+ } in
+ let e = loop ctx e in
+ e,ctx
+
+ let unapply com e =
+ let rec loop e = match e.eexpr with
+ | TFor(v,e1,e2) when Meta.has (Meta.Custom ":ssa") v.v_meta ->
+ let v' = get_origin_var v in
+ let e1 = loop e1 in
+ let e2 = loop e2 in
+ {e with eexpr = TFor(v',e1,e2)}
+ | TLocal v when Meta.has (Meta.Custom ":ssa") v.v_meta ->
+ let v' = get_origin_var v in
+ {e with eexpr = TLocal v'}
+ | TBlock el ->
+ let rec filter e = match e.eexpr with
+ | TMeta((Meta.Custom ":ssa",_,_),_) ->
+ false
+ | _ ->
+ true
+ in
+ let el = List.filter filter el in
+ let el = List.map loop el in
+ {e with eexpr = TBlock el}
+ | _ ->
+ Type.map_expr loop e
+ in
+ loop e
+end
+
+module ConstPropagation = struct
+ open Ssa
+
+ let expr_eq e1 e2 = match e1.eexpr,e2.eexpr with
+ | TConst ct1, TConst ct2 ->
+ ct1 = ct2
+ | _ ->
+ false
+
+ let get_block_depth v = try
+ let i = match Meta.get (Meta.Custom ":blockDepth") v.v_meta with
+ | _,[EConst(Int s),_],_ -> int_of_string s
+ | _ -> raise Not_found
+ in
+ i
+ with Not_found ->
+ -1
+
+ let can_be_inlined com v0 e = type_iseq v0.v_type e.etype && match e.eexpr with
+ | TConst ct ->
+ begin match ct with
+ | TThis | TSuper -> false
+ (* Some targets don't like seeing null in certain places and won't even compile. We have to detect `if (x != null)
+ in order for this to work. *)
+ | TNull when (match com.platform with Php | Cpp -> true | _ -> false) -> false
+ | _ -> true
+ end
+ | TLocal v ->
+ not (Meta.has Meta.CompilerGenerated v.v_meta) &&
+ begin try
+ let v' = Ssa.get_origin_var v in
+ begin match v'.v_extra with
+ | Some ([],_) -> get_block_depth v <= get_block_depth v0
+ | _ -> false
+ end
+ with Not_found ->
+ false
+ end
+ | TEnumParameter _ when not (com.platform = Php) ->
+ Ssa.get_var_usage_count v0 <= 1
+ | _ ->
+ false
+
+ let semi_awkward_enum_value ssa e i = match e.eexpr with
+ | TCall({eexpr = TField(_,FEnum _)},el) -> (try List.nth el i with Failure _ -> raise Not_found)
+ | _ -> raise Not_found
+
+ let rec local ssa force v e =
+ begin try
+ if v.v_capture then raise Not_found;
+ if type_has_analyzer_option v.v_type flag_no_const_propagation then raise Not_found;
+ begin match follow v.v_type with
+ | TDynamic _ -> raise Not_found
+ | _ -> ()
+ end;
+ let e = Ssa.get_var_value v in
+ let old = v.v_extra in
+ v.v_extra <- None;
+ let e = value ssa force e in
+ v.v_extra <- old;
+ Ssa.set_var_value v e;
+ e
+ with Not_found ->
+ e
+ end
+
+ (* force must only be true if the value is not used in the output *)
+ and value ssa force e = match e.eexpr with
+ | TUnop((Increment | Decrement),_,_)
+ | TBinop(OpAssignOp _,_,_)
+ | TBinop(OpAssign,_,_) ->
+ e
+ | TBinop(op,e1,e2) ->
+ let e1 = value ssa force e1 in
+ let e2 = value ssa force e2 in
+ let e = {e with eexpr = TBinop(op,e1,e2)} in
+ let e' = Optimizer.optimize_binop e op e1 e2 in
+ if e == e' then
+ e
+ else
+ value ssa force e'
+ | TUnop(op,flag,e1) ->
+ let e1 = value ssa force e1 in
+ let e = {e with eexpr = TUnop(op,flag,e1)} in
+ let e' = Optimizer.optimize_unop e op flag e1 in
+ if e == e' then
+ e
+ else
+ value ssa force e'
+ | TCall (({eexpr = TLocal {v_name = "__ssa_phi__"}} as ephi),el) ->
+ let el = List.map (value ssa force) el in
+ begin match el with
+ | [] -> assert false
+ | e1 :: el ->
+ if List.for_all (fun e2 -> expr_eq e1 e2) el then
+ value ssa force e1
+ else
+ {e with eexpr = TCall(ephi, e1 :: el)}
+ end
+ | TParenthesis e1 | TMeta(_,e1) ->
+ value ssa force e1
+ | TLocal v ->
+ let e' = local ssa force v e in
+ if force || can_be_inlined ssa.com v e' then
+ e'
+ else
+ e
+ | TEnumParameter(e1,ef,i) ->
+ let ev = value ssa true e1 in
+ begin try
+ value ssa force (semi_awkward_enum_value ssa ev i)
+ with Not_found ->
+ e
+ end
+ | _ ->
+ e
+
+ (* TODO: the name is quite accurate *)
+ let awkward_get_enum_index ssa e =
+ let e = awkward_get_enum_index ssa.com e in
+ let ev = (value ssa true e) in
+ match ev.eexpr with
+ | TField(_,FEnum(_,ef)) -> TInt (Int32.of_int ef.ef_index)
+ | TCall({eexpr = TField(_,FEnum(_,ef))},_) -> TInt (Int32.of_int ef.ef_index)
+ | _ -> raise Not_found
+
+ let apply ssa e =
+ let rec loop e = match e.eexpr with
+ | TLocal v when not (Meta.has Meta.Unbound v.v_meta) ->
+ set_var_usage_count v (get_var_usage_count v + 1);
+ | _ ->
+ Type.iter loop e
+ in
+ loop e;
+ let had_function = ref false in
+ let rec loop e = match e.eexpr with
+ | TFunction _ when !had_function ->
+ e
+ | TFunction tf ->
+ had_function := true;
+ {e with eexpr = TFunction {tf with tf_expr = loop tf.tf_expr}}
+ | TLocal v ->
+ let e' = local ssa false v e in
+ if can_be_inlined ssa.com v e' then
+ e'
+ else
+ e
+ | TCall({eexpr = TField(_,(FStatic(_,cf) | FInstance(_,_,cf) | FAnon cf))},el) when has_analyzer_option cf.cf_meta flag_no_const_propagation ->
+ e
+ | TCall(e1,el) ->
+ let e1 = loop e1 in
+ let check e t =
+ if type_has_analyzer_option t flag_no_const_propagation then e
+ else loop e
+ in
+ let el = Codegen.UnificationCallback.check_call check el e1.etype in
+ {e with eexpr = TCall(e1,el)}
+(* | TField(e1,fa) ->
+ let e1' = loop e1 in
+ let fa = if e1' != e1 then
+ begin try quick_field e1'.etype (field_name fa)
+ with Not_found -> fa end
+ else
+ fa
+ in
+ {e with eexpr = TField(e1',fa)} *)
+ | TUnop((Increment | Decrement),_,_) ->
+ e
+ | TBinop(OpAssignOp op,e1,e2) ->
+ let e2 = loop e2 in
+ {e with eexpr = TBinop(OpAssignOp op,e1,e2)}
+ | TBinop(OpAssign,({eexpr = TLocal _} as e1),e2) ->
+ let e2 = loop e2 in
+ {e with eexpr = TBinop(OpAssign,e1,e2)}
+ | TBinop(op,e1,e2) ->
+ let e1 = loop e1 in
+ let e2 = loop e2 in
+ let e = {e with eexpr = TBinop(op,e1,e2)} in
+ let e' = Optimizer.optimize_binop e op e1 e2 in
+ e'
+ | TUnop(op,flag,e1) ->
+ let e1 = loop e1 in
+ let e = {e with eexpr = TUnop(op,flag,e1)} in
+ let e' = Optimizer.optimize_unop e op flag e1 in
+ e'
+ | TIf(e1,e2,eo) ->
+ let e1 = loop e1 in
+ let e2 = loop e2 in
+ let rec check_const e1 = match e1.eexpr with
+ | TConst (TBool true) ->
+ e2
+ | TConst (TBool false) ->
+ begin match eo with
+ | None ->
+ mk (TConst TNull) t_dynamic e.epos
+ | Some e ->
+ loop e
+ end
+ | TParenthesis e1 ->
+ check_const e1
+ | _ ->
+ let eo = match eo with None -> None | Some e -> Some (loop e) in
+ {e with eexpr = TIf(e1,e2,eo)}
+ in
+ check_const e1
+ | TSwitch(e1,cases,edef) ->
+ let e1 = loop e1 in
+ let rec check_constant e = match e.eexpr with
+ | TConst ct -> ct
+ | TParenthesis e1 | TCast(e1,None) | TMeta(_,e1) -> check_constant e1
+ | _ -> awkward_get_enum_index ssa e
+ in
+ begin try
+ let ct = check_constant e1 in
+ begin try
+ let _,e = List.find (fun (el,_) ->
+ List.exists (fun e -> match e.eexpr with
+ | TConst ct2 -> ct = ct2
+ | _ -> false
+ ) el
+ ) cases in
+ loop e
+ with Not_found ->
+ begin match edef with None -> raise Not_found | Some e -> loop e end
+ end
+ with Not_found ->
+ let cases = List.map (fun (el,e) -> el,loop e) cases in
+ let edef = match edef with None -> None | Some e -> Some (loop e) in
+ {e with eexpr = TSwitch(e1,cases,edef)}
+ end
+ | _ ->
+ Type.map_expr loop e
+ in
+ loop e
+end
+
+module EffectChecker = struct
+ let run com is_var_expression e =
+ let has_effect e = match e.eexpr with
+ | TVar _ -> true
+ | _ -> Optimizer.has_side_effect e
+ in
+ let e = if is_var_expression then
+ (* var initialization expressions are like assignments, so let's cheat a bit here *)
+ snd (Simplifier.apply com (Codegen.binop OpAssign (mk (TConst TNull) t_dynamic e.epos) e e.etype e.epos))
+ else e
+ in
+ let rec loop e = match e.eexpr with
+ | TBlock el ->
+ List.iter (fun e ->
+ if not (has_effect e) then com.warning "This expression has no effect" e.epos
+ ) el
+ | _ ->
+ Type.iter loop e
+ in
+ loop e
+end
+
+module Checker = struct
+ open Ssa
+
+ let apply ssa e =
+ let given_warnings = ref PMap.empty in
+ let add_pos p =
+ given_warnings := PMap.add p true !given_warnings
+ in
+ let resolve_value v =
+ let e' = Ssa.get_var_value v in
+ begin match e'.eexpr with
+ | TLocal v' when v == v' -> e'
+ | _ -> e'
+ end
+ in
+ let rec is_null_expr e = match e.eexpr with
+ | TConst TNull ->
+ true
+ | TLocal v ->
+ (try is_null_expr (resolve_value v) with Not_found -> false)
+ | _ ->
+ false
+ in
+ let can_be_null v =
+ not (has_meta Meta.NotNull v.v_meta)
+ && try not (List.exists (fun cond -> match cond with
+ | NotEqual(v',e) when v == v' && is_null_expr e -> true
+ | _ -> false
+ ) (IntMap.find v.v_id ssa.var_conds)) with Not_found -> true
+ in
+ let return b p =
+ if b then add_pos p;
+ b
+ in
+ let rec can_be_null_expr vstack e =
+ if PMap.mem e.epos !given_warnings then
+ false
+ else match e.eexpr with
+ | TConst TNull ->
+ add_pos e.epos;
+ true
+ | TBinop((OpAssign | OpAssignOp _),_,e1) ->
+ can_be_null_expr vstack e1
+ | TBinop _ | TUnop _ ->
+ false
+ | TConst _ | TTypeExpr _ | TNew _ | TObjectDecl _ | TArrayDecl _ | TEnumParameter _ | TFunction _ | TVar _ ->
+ false
+ | TFor _ | TWhile _ | TIf _ | TSwitch _ | TTry _ | TReturn _ | TBreak | TContinue | TThrow _ ->
+ assert false
+ | TField _ | TBlock _ | TArray _ ->
+ false (* TODO *)
+ | TCall ({eexpr = TLocal {v_name = "__ssa_phi__"}},el) ->
+ List.exists (can_be_null_expr vstack) el
+ | TLocal v ->
+ if List.mem v.v_id vstack then
+ false (* not really, but let's not be a nuisance *)
+ else
+ return (can_be_null v && (try can_be_null_expr (v.v_id :: vstack) (resolve_value v) with Not_found -> true)) e.epos;
+ | TMeta(_,e1) | TParenthesis e1 | TCast(e1,_) ->
+ can_be_null_expr vstack e1
+ | TCall(e1,_) ->
+ begin match follow e1.etype with
+ | TFun(_,r) -> return (is_explicit_null r) e1.epos
+ | _ -> false
+ end
+ in
+ let check_null e p =
+ if can_be_null_expr [] e then begin
+ ssa.com.warning "Possible null exception" p;
+ end
+ in
+ let rec loop e = match e.eexpr with
+ | TField(e1,fa) ->
+ let e1 = loop e1 in
+ check_null e1 e.epos;
+ {e with eexpr = TField(e1,fa)}
+ | TMeta((Meta.Analyzer,[EConst(Ident "testIsNull"),_],_),e1) ->
+ if not (can_be_null_expr [] e) then error "Analyzer did not find a possible null exception" e.epos;
+ e
+ | TMeta((Meta.Analyzer,[EConst(Ident "testIsNotNull"),_],_),e1) ->
+ if (can_be_null_expr [] e) then error "Analyzer found a possible null exception" e.epos;
+ e
+ | _ ->
+ Type.map_expr loop e
+ in
+ loop e;
+end
+
+let rec lrev_iter f el = match el with
+ | e :: el ->
+ lrev_iter f el;
+ f e
+ | [] ->
+ ()
+
+let rev_iter f e = match e.eexpr with
+ | TConst _
+ | TLocal _
+ | TBreak
+ | TContinue
+ | TTypeExpr _ ->
+ ()
+ | TArray (e1,e2)
+ | TBinop (_,e1,e2)
+ | TFor (_,e1,e2)
+ | TWhile (e1,e2,_) ->
+ f e2;
+ f e1;
+ | TThrow e
+ | TField (e,_)
+ | TEnumParameter (e,_,_)
+ | TParenthesis e
+ | TCast (e,_)
+ | TUnop (_,_,e)
+ | TMeta(_,e) ->
+ f e
+ | TArrayDecl el
+ | TNew (_,_,el)
+ | TBlock el ->
+ lrev_iter f el
+ | TObjectDecl fl ->
+ lrev_iter (fun (_,e) -> f e) fl
+ | TCall (e,el) ->
+ f e;
+ lrev_iter f el
+ | TVar (v,eo) ->
+ (match eo with None -> () | Some e -> f e)
+ | TFunction fu ->
+ f fu.tf_expr
+ | TIf (e,e1,e2) ->
+ (match e2 with None -> () | Some e -> f e);
+ f e1;
+ f e;
+ | TSwitch (e,cases,def) ->
+ (match def with None -> () | Some e -> f e);
+ lrev_iter (fun (el,e2) -> lrev_iter f el; f e2) cases;
+ f e;
+ | TTry (e,catches) ->
+ lrev_iter (fun (_,e) -> f e) catches;
+ f e;
+ | TReturn eo ->
+ (match eo with None -> () | Some e -> f e)
+
+module LocalDce = struct
+ let apply e =
+ let is_used v = Meta.has Meta.Used v.v_meta || type_has_analyzer_option v.v_type flag_no_local_dce || v.v_capture in
+ let is_ref_type t = match t with
+ | TType({t_path = ["cs"],("Ref" | "Out")},_) -> true
+ | _ -> false
+ in
+ let rec use v =
+ if not (Meta.has Meta.Used v.v_meta) then begin
+ v.v_meta <- (Meta.Used,[],Ast.null_pos) :: v.v_meta;
+ try use (Ssa.get_origin_var v) with Not_found -> ()
+ end
+ in
+ let rec has_side_effect e =
+ let rec loop e =
+ match e.eexpr with
+ | TLocal v when Meta.has Meta.CompilerGenerated v.v_meta -> (try loop (Ssa.get_var_value v) with Not_found -> ())
+ | TBinop((OpAssign | OpAssignOp _),{eexpr = TLocal v},e2) when is_used v || has_side_effect e2 || is_ref_type v.v_type -> raise Exit
+ | TVar(v,None) when is_used v -> raise Exit
+ | TVar(v,Some e1) when is_used v || has_side_effect e1 -> raise Exit
+ | TConst _ | TLocal _ | TTypeExpr _ | TFunction _ -> ()
+ | TCall ({ eexpr = TField(_,FStatic({ cl_path = ([],"Std") },{ cf_name = "string" })) },args) -> Type.iter loop e
+ | TCall (({eexpr = TLocal {v_name = "__ssa_phi__"}}),el) -> ()
+ | TCall ({eexpr = TField(_,FEnum _)},_) -> Type.iter loop e
+ | TNew _ | TCall _ | TBinop ((OpAssignOp _ | OpAssign),_,_) | TUnop ((Increment|Decrement),_,_) -> raise Exit
+ | TReturn _ | TBreak | TContinue | TThrow _ | TCast (_,Some _) -> raise Exit
+ | TFor _ -> raise Exit
+ | TArray _ | TEnumParameter _ | TCast (_,None) | TBinop _ | TUnop _ | TParenthesis _ | TMeta _ | TWhile _
+ | TField _ | TIf _ | TTry _ | TSwitch _ | TArrayDecl _ | TBlock _ | TObjectDecl _ | TVar _ -> Type.iter loop e
+ in
+ try
+ loop e;
+ false
+ with Exit ->
+ true
+ in
+ let rec collect e = match e.eexpr with
+ | TLocal v ->
+ use v
+ | TVar(v,_) when not (is_used v) ->
+ (* TODO: this is probably dangerous *)
+ ()
+ | _ ->
+ rev_iter collect e
+ in
+ let rec loop need_val e =
+ match e.eexpr with
+ | TLocal v ->
+ use v;
+ e
+ | TBinop(OpAssign,({eexpr = TLocal v} as e1),e2) ->
+ let e2 = loop false e2 in
+ if not (is_used v) && not (is_ref_type v.v_type) then
+ e2
+ else
+ {e with eexpr = TBinop(OpAssign,{e1 with eexpr = TLocal v},e2)}
+ | TVar(v,Some e1) when not (is_used v) ->
+ let e1 = if has_side_effect e1 then loop true e1 else e1 in
+ e1
+ | TWhile(e1,e2,flag) ->
+ collect e2;
+ let e2 = loop false e2 in
+ let e1 = loop false e1 in
+ {e with eexpr = TWhile(e1,e2,flag)}
+ | TFor(v,e1,e2) ->
+ collect e2;
+ let e2 = loop false e2 in
+ let e1 = loop false e1 in
+ {e with eexpr = TFor(v,e1,e2)}
+ | TBlock el ->
+ let rec block el = match el with
+ | e :: el ->
+ let el = block el in
+ if not need_val && not (has_side_effect e) then
+ el
+ else begin
+ let e = loop false e in
+ e :: el
+ end
+ | [] ->
+ []
+ in
+ {e with eexpr = TBlock (block el)}
+ | TCall(e1, el) ->
+ let el = List.rev_map (loop true) (List.rev el) in
+ let e1 = loop false e1 in
+ {e with eexpr = TCall(e1,el)}
+ | TIf(e1,e2,e3) ->
+ let e3 = match e3 with None -> None | Some e -> Some (loop need_val e) in
+ let e2 = loop need_val e2 in
+ let e1 = loop false e1 in
+ {e with eexpr = TIf(e1,e2,e3)}
+ | TArrayDecl el ->
+ let el = List.rev_map (loop true) (List.rev el) in
+ {e with eexpr = TArrayDecl el}
+ | TObjectDecl fl ->
+ let fl = List.rev_map (fun (s,e) -> s,loop true e) (List.rev fl) in
+ {e with eexpr = TObjectDecl fl}
+ | _ ->
+ Type.map_expr (loop false) e
+ in
+ loop false e
+end
+
+module Config = struct
+
+ type analyzer_config = {
+ analyzer_use : bool;
+ simplifier_apply : bool;
+ ssa_apply : bool;
+ const_propagation : bool;
+ check : bool;
+ check_has_effect : bool;
+ local_dce : bool;
+ ssa_unapply : bool;
+ simplifier_unapply : bool;
+ }
+
+ let get_base_config com =
+ {
+ analyzer_use = true;
+ simplifier_apply = true;
+ ssa_apply = true;
+ const_propagation = not (Common.raw_defined com "analyzer-no-const-propagation");
+ check_has_effect = (Common.raw_defined com "analyzer-check-has-effect");
+ check = not (Common.raw_defined com "analyzer-no-check");
+ local_dce = not (Common.raw_defined com "analyzer-no-local-dce") && not (Common.defined com Define.As3);
+ ssa_unapply = not (Common.raw_defined com "analyzer-no-ssa-unapply");
+ simplifier_unapply = not (Common.raw_defined com "analyzer-no-simplify-unapply");
+ }
+
+ let update_config_from_meta config meta =
+ List.fold_left (fun config meta -> match meta with
+ | (Meta.Analyzer,el,_) ->
+ List.fold_left (fun config e -> match fst e with
+ | EConst (Ident s) when s = flag_no_check -> { config with check = false}
+ | EConst (Ident s) when s = flag_check -> { config with check = true}
+ | EConst (Ident s) when s = flag_no_const_propagation -> { config with const_propagation = false}
+ | EConst (Ident s) when s = flag_const_propagation -> { config with const_propagation = true}
+ | EConst (Ident s) when s = flag_no_local_dce -> { config with local_dce = false}
+ | EConst (Ident s) when s = flag_local_dce -> { config with local_dce = true}
+ | EConst (Ident s) when s = flag_no_check_has_effect -> { config with check_has_effect = false}
+ | EConst (Ident s) when s = flag_check_has_effect -> { config with check_has_effect = true}
+ | _ -> config
+ ) config el
+ | _ ->
+ config
+ ) config meta
+
+ let get_class_config com c =
+ let config = get_base_config com in
+ update_config_from_meta config c.cl_meta
+
+ let get_field_config com c cf =
+ let config = get_class_config com c in
+ update_config_from_meta config cf.cf_meta
+end
+
+module Run = struct
+
+ open Config
+
+ let run_on_expr com config is_var_expression e =
+ let do_simplify = (not (Common.defined com Define.NoSimplify) ) && match com.platform with
+ | Cpp when Common.defined com Define.Cppia -> false
+ | Cpp | Python -> true
+ | _ -> false
+ in
+ let with_timer s f =
+ let timer = timer s in
+ let r = f() in
+ timer();
+ r
+ in
+ try
+ let has_unbound,e = if do_simplify || config.analyzer_use then
+ with_timer "analyzer-simplify-apply" (fun () -> Simplifier.apply com e)
+ else
+ false,e
+ in
+ let e = if config.analyzer_use && not has_unbound then begin
+ if config.check_has_effect then EffectChecker.run com is_var_expression e;
+ let e,ssa = with_timer "analyzer-ssa-apply" (fun () -> Ssa.apply com e) in
+ let e = if config.const_propagation then with_timer "analyzer-const-propagation" (fun () -> ConstPropagation.apply ssa e) else e in
+ (* let e = if config.check then with_timer "analyzer-checker" (fun () -> Checker.apply ssa e) else e in *)
+ let e = if config.local_dce && config.analyzer_use && not has_unbound && not is_var_expression then with_timer "analyzer-local-dce" (fun () -> LocalDce.apply e) else e in
+ let e = if config.ssa_unapply then with_timer "analyzer-ssa-unapply" (fun () -> Ssa.unapply com e) else e in
+ List.iter (fun f -> f()) ssa.Ssa.cleanup;
+ e
+ end else
+ e
+ in
+ let e = if not do_simplify && not (Common.raw_defined com "analyzer-no-simplify-unapply") then
+ with_timer "analyzer-simplify-unapply" (fun () -> Simplifier.unapply com e)
+ else
+ e
+ in
+ e
+ with Exit ->
+ e
+
+ let run_on_field ctx config cf =
+ match cf.cf_expr with
+ | Some e when not (is_ignored cf.cf_meta) && not (Codegen.is_removable_field ctx cf) ->
+ let config = update_config_from_meta config cf.cf_meta in
+ let is_var_expression = match cf.cf_kind with
+ | Var _ -> true
+ | _ -> false
+ in
+ cf.cf_expr <- Some (run_on_expr ctx.com config is_var_expression e);
+ | _ -> ()
+
+ let run_on_class ctx config c =
+ let config = update_config_from_meta config c.cl_meta in
+ let process_field cf = run_on_field ctx config cf in
+ List.iter process_field c.cl_ordered_fields;
+ List.iter process_field c.cl_ordered_statics;
+ (match c.cl_constructor with
+ | None -> ()
+ | Some f -> process_field f);
+ (match c.cl_init with
+ | None -> ()
+ | Some e ->
+ (* never optimize init expressions (too messy) *)
+ c.cl_init <- Some (run_on_expr ctx.com {config with analyzer_use = false} false e))
+
+ let run_on_type ctx config t =
+ match t with
+ | TClassDecl c when (is_ignored c.cl_meta) -> ()
+ | TClassDecl c -> run_on_class ctx config c
+ | TEnumDecl _ -> ()
+ | TTypeDecl _ -> ()
+ | TAbstractDecl _ -> ()
+
+ let run_on_types ctx types =
+ let com = ctx.com in
+ let config = get_base_config com in
+ List.iter (run_on_type ctx config) types
+
+end
diff --git a/appveyor.yml b/appveyor.yml
new file mode 100644
index 0000000000000000000000000000000000000000..53b1b519339476dde708c395fc79bbd9dd2ffa48
--- /dev/null
+++ b/appveyor.yml
@@ -0,0 +1,68 @@
+version: "{build}"
+
+os: unstable #http://help.appveyor.com/discussions/suggestions/427-pre-install-cygwin
+
+platform:
+ - Win32
+
+environment:
+ global:
+ NEKO_ROOT: C:/projects/neko
+ HAXELIB_ROOT: C:/projects/haxelib
+ CYG_ARCH: x86
+ CYG_ROOT: C:/cygwin
+ CYG_SETUP: C:/cygwin/setup-x86.exe
+ MINGW_ARCH: i686
+ WODI: wodi32
+ ADD_REVISION: 1
+ OCAMLOPT: ocamlopt.opt
+ matrix:
+ - TEST: "neko,cs,java,macro"
+ - TEST: "cpp"
+
+skip_tags: true
+
+install:
+ - 'git submodule update --init --recursive'
+ - cinst 7zip.commandline -y
+ # Install ocaml using wodi
+ - appveyor DownloadFile "http://cygwin.com/setup-%CYG_ARCH%.exe" -FileName "%CYG_ROOT%\setup.exe"
+ - '%CYG_ROOT%/setup.exe -g -q -R "%CYG_ROOT%" -P dos2unix -P diffutils -P cpio -P make -P patch -P mingw64-%MINGW_ARCH%-gcc-core -P mingw64-%MINGW_ARCH%-gcc-g++ > log.txt || type log.txt'
+ - '%CYG_ROOT%/bin/bash -lc "cygcheck -dc cygwin" > log.txt || type log.txt'
+ # The archive is a dropbox hosted version of https://github.com/fdopen/godi-repo/issues/7#issuecomment-98480339
+ - '%CYG_ROOT%/bin/bash -lc "wget -q https://dl.dropboxusercontent.com/u/2661116/wodi/%WODI%.tar.xz -O /tmp/%WODI%.tar.xz" > log.txt || type log.txt'
+ - '%CYG_ROOT%/bin/bash -lc "cd /tmp && rm -rf %WODI% && tar -xf %WODI%.tar.xz && bash %WODI%/install.sh" > log.txt || type log.txt'
+ - '%CYG_ROOT%/bin/bash -lc "godi_add godi-zip" > log.txt || type log.txt'
+ - 'set PATH=%PATH%;%CYG_ROOT%/opt/%WODI%/bin'
+ # Install neko
+ - cinst make -y
+ - 'git clone --recursive https://github.com/HaxeFoundation/neko.git %NEKO_ROOT%'
+ - 'cd %NEKO_ROOT%'
+ - set PATH=%PATH%;%NEKO_ROOT%/bin
+ - msbuild neko_vc10.sln /verbosity:minimal /logger:"C:\Program Files\AppVeyor\BuildAgent\Appveyor.MSBuildLogger.dll" > log.txt || type log.txt
+ - msbuild libs/libs_vc10.sln /verbosity:minimal /logger:"C:\Program Files\AppVeyor\BuildAgent\Appveyor.MSBuildLogger.dll" > log.txt || type log.txt
+ - copy /y libs\include\gc\gc.dll bin
+ - cd %NEKO_ROOT%/src
+ - neko ../boot/nekoc tools/install.neko
+ - neko tools/install -nolibs > log.txt || type log.txt
+ - neko -version
+
+build_script:
+ - 'cd %APPVEYOR_BUILD_FOLDER%'
+ - 'set PATH=%PATH%;%APPVEYOR_BUILD_FOLDER%'
+ - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && make -s -f Makefile.win"'
+ - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && make -s -f Makefile.win tools"'
+ - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && make -s -f Makefile.win package_bin"'
+ - dir %APPVEYOR_BUILD_FOLDER%\out
+ - cd %APPVEYOR_BUILD_FOLDER%/tests/
+ - mkdir "%HAXELIB_ROOT%"
+ - haxelib setup "%HAXELIB_ROOT%"
+
+test_script:
+ - cd %APPVEYOR_BUILD_FOLDER%/tests/
+ - haxe -version
+ - haxe RunCi.hxml
+ - neko RunCi.n
+
+artifacts:
+ - path: out/haxe_*.zip
diff --git a/ast.ml b/ast.ml
old mode 100755
new mode 100644
index 1017568718bfe02287e91872def138c63b08faec..bcd6b95ec7e710629ccc9fe8582443e4b0bec4ac
--- a/ast.ml
+++ b/ast.ml
@@ -26,18 +26,26 @@ type pos = {
pmax : int;
}
+module IntMap = Map.Make(struct type t = int let compare a b = a - b end)
+
module Meta = struct
type strict_meta =
+ | Abi
| Abstract
| Access
+ | Accessor
| Allow
+ | Analyzer
| Annotation
| ArrayAccess
+ | Ast
| AutoBuild
| Bind
| Bitmap
+ | BridgeProperties
| Build
| BuildXml
+ | Callable
| Class
| ClassCode
| Commutative
@@ -45,54 +53,78 @@ module Meta = struct
| CoreApi
| CoreType
| CppFileCode
+ | CppInclude
| CppNamespaceCode
+ | CsNative
+ | Dce
| Debug
| Decl
| DefParam
+ | Delegate
| Depend
| Deprecated
+ | DirectlyUsed
| DynamicObject
| Enum
| EnumConstructorParam
+ | Event
+ | Exhaustive
| Expose
| Extern
| FakeEnum
| File
| Final
+ | FlatEnum
| Font
+ | Forward
| From
| FunctionCode
| FunctionTailCode
| Generic
+ | GenericBuild
+ | GenericInstance
| Getter
| Hack
+ | HasUntyped
| HaxeGeneric
| HeaderClassCode
| HeaderCode
+ | HeaderInclude
| HeaderNamespaceCode
| HxGen
| IfFeature
| Impl
+ | PythonImport
+ | ImplicitCast
| Include
| InitPackage
| Internal
| IsVar
+ | JavaCanonical
| JavaNative
+ | JsRequire
| Keep
| KeepInit
| KeepSub
+ | LibType
| Meta
| Macro
| MaybeUsed
+ | MergeBlock
| MultiType
| Native
+ | NativeChildren
| NativeGen
| NativeGeneric
+ | NativeProperty
| NoCompletion
| NoDebug
| NoDoc
+ | NoExpr
| NoImportGlobal
+ | NonVirtual
| NoPackageRestrict
+ | NoPrivateAccess
| NoStack
| NotNull
| NoUsing
@@ -101,34 +133,47 @@ module Meta = struct
| Optional
| Overload
| PrivateAccess
+ | Property
| Protected
| Public
| PublicFields
+ | QuotedField
| ReadOnly
| RealPath
| Remove
| Require
+ | RequiresAssign
+ (* | Resolve *)
| ReplaceReflection
| Rtti
| Runtime
| RuntimeValue
+ | SelfCall
| Setter
| SkipCtor
| SkipReflection
| Sound
+ | SourceFile
+ | StoredTypedExpr
+ | Strict
| Struct
+ | StructAccess
| SuppressWarnings
+ | This
| Throws
| To
| ToString
| Transient
| ValueUsed
| Volatile
+ | Unbound
| UnifyMinDynamic
| Unreflective
| Unsafe
| Usage
| Used
+ | Value
+ | Void
| Last
(* do not put any custom metadata after Last *)
| Dollar of string
@@ -136,6 +181,9 @@ module Meta = struct
let has m ml = List.exists (fun (m2,_,_) -> m = m2) ml
let get m ml = List.find (fun (m2,_,_) -> m = m2) ml
+
+ let to_string_ref = ref (fun _ -> assert false)
+ let to_string (m : strict_meta) : string = !to_string_ref m
end
type keyword =
@@ -270,7 +318,7 @@ and complex_type =
| CTFunction of complex_type list * complex_type
| CTAnonymous of class_field list
| CTParent of complex_type
- | CTExtend of type_path * class_field list
+ | CTExtend of type_path list * class_field list
| CTOptional of complex_type
and func = {
@@ -401,6 +449,8 @@ type type_decl = type_def * pos
type package = string list * type_decl list
+exception Error of string * pos
+
let is_lower_ident i =
let rec loop p =
match String.unsafe_get i p with
@@ -412,8 +462,8 @@ let is_lower_ident i =
let pos = snd
-let is_postfix (e,_) = function
- | Increment | Decrement -> (match e with EConst _ | EField _ | EArray _ -> true | _ -> false)
+let rec is_postfix (e,_) op = match op with
+ | Increment | Decrement -> true
| Not | Neg | NegBits -> false
let is_prefix = function
@@ -446,7 +496,7 @@ let parse_path s =
| [] -> failwith "Invalid empty path"
| x :: l -> List.rev l, x
-let s_escape s =
+let s_escape ?(hex=true) s =
let b = Buffer.create (String.length s) in
for i = 0 to (String.length s) - 1 do
match s.[i] with
@@ -455,6 +505,7 @@ let s_escape s =
| '\r' -> Buffer.add_string b "\\r"
| '"' -> Buffer.add_string b "\\\""
| '\\' -> Buffer.add_string b "\\\\"
+ | c when int_of_char c < 32 && hex -> Buffer.add_string b (Printf.sprintf "\\x%.2X" (int_of_char c))
| c -> Buffer.add_char b c
done;
Buffer.contents b
@@ -598,6 +649,23 @@ let unescape s =
let c = (try char_of_int (int_of_string ("0x" ^ String.sub s (i+1) 2)) with _ -> raise Exit) in
Buffer.add_char b c;
inext := !inext + 2;
+ | 'u' ->
+ let (u, a) =
+ try
+ (int_of_string ("0x" ^ String.sub s (i+1) 4), 4)
+ with _ -> try
+ assert (s.[i+1] = '{');
+ let l = String.index_from s (i+3) '}' - (i+2) in
+ let u = int_of_string ("0x" ^ String.sub s (i+2) l) in
+ assert (u <= 0x10FFFF);
+ (u, l+2)
+ with _ ->
+ raise Exit
+ in
+ let ub = UTF8.Buf.create 0 in
+ UTF8.Buf.add_char ub (UChar.uchar_of_int u);
+ Buffer.add_string b (UTF8.Buf.contents ub);
+ inext := !inext + a;
| _ ->
raise Exit);
loop false !inext;
@@ -630,7 +698,7 @@ let map_expr loop (e,p) =
| CTFunction (cl,c) -> CTFunction (List.map ctype cl, ctype c)
| CTAnonymous fl -> CTAnonymous (List.map cfield fl)
| CTParent t -> CTParent (ctype t)
- | CTExtend (t,fl) -> CTExtend (tpath t, List.map cfield fl)
+ | CTExtend (tl,fl) -> CTExtend (List.map tpath tl, List.map cfield fl)
| CTOptional t -> CTOptional (ctype t)
and tparamdecl t =
{ tp_name = t.tp_name; tp_constraints = List.map ctype t.tp_constraints; tp_params = List.map tparamdecl t.tp_params }
@@ -676,3 +744,29 @@ let map_expr loop (e,p) =
| EMeta (m,e) -> EMeta(m, loop e)
) in
(e,p)
+
+let rec s_expr (e,_) =
+ match e with
+ | EConst c -> s_constant c
+ | EParenthesis e -> "(" ^ (s_expr e) ^ ")"
+ | EArrayDecl el -> "[" ^ (String.concat "," (List.map s_expr el)) ^ "]"
+ | EObjectDecl fl -> "{" ^ (String.concat "," (List.map (fun (n,e) -> n ^ ":" ^ (s_expr e)) fl)) ^ "}"
+ | EBinop (op,e1,e2) -> s_expr e1 ^ s_binop op ^ s_expr e2
+ | ECall (e,el) -> s_expr e ^ "(" ^ (String.concat ", " (List.map s_expr el)) ^ ")"
+ | EField (e,f) -> s_expr e ^ "." ^ f
+ | _ -> "'???'"
+
+let get_value_meta meta =
+ try
+ begin match Meta.get Meta.Value meta with
+ | (_,[EObjectDecl values,_],_) -> List.fold_left (fun acc (s,e) -> PMap.add s e acc) PMap.empty values
+ | _ -> raise Not_found
+ end
+ with Not_found ->
+ PMap.empty
+
+let rec string_list_of_expr_path_raise (e,p) =
+ match e with
+ | EConst (Ident i) -> [i]
+ | EField (e,f) -> f :: string_list_of_expr_path_raise e
+ | _ -> raise Exit
diff --git a/codegen.ml b/codegen.ml
index 078b8c545e20c26ec86154e09643682651b4351d..7b51b2afcab6f65b7179652a824599e587f5ed8e 100644
--- a/codegen.ml
+++ b/codegen.ml
@@ -47,14 +47,12 @@ let binop op a b t p =
let index com e index t p =
mk (TArray (e,mk (TConst (TInt (Int32.of_int index))) com.basic.tint p)) t p
-let concat e1 e2 =
- let e = (match e1.eexpr, e2.eexpr with
- | TBlock el1, TBlock el2 -> TBlock (el1@el2)
- | TBlock el, _ -> TBlock (el @ [e2])
- | _, TBlock el -> TBlock (e1 :: el)
- | _ , _ -> TBlock [e1;e2]
- ) in
- mk e e2.etype (punion e1.epos e2.epos)
+let maybe_cast e t =
+ try
+ type_eq EqDoNotFollowNull e.etype t;
+ e
+ with
+ Unify_error _ -> mk (TCast(e,None)) t e.epos
let type_constant com c p =
let t = com.basic in
@@ -89,17 +87,21 @@ let rec has_properties c =
match f.cf_kind with
| Var { v_read = AccCall } -> true
| Var { v_write = AccCall } -> true
+ | _ when Meta.has Meta.Accessor f.cf_meta -> true
| _ -> false
) c.cl_ordered_fields || (match c.cl_super with Some (c,_) -> has_properties c | _ -> false)
let get_properties fields =
List.fold_left (fun acc f ->
- let acc = (match f.cf_kind with
- | Var { v_read = AccCall } -> ("get_" ^ f.cf_name , "get_" ^ f.cf_name) :: acc
- | _ -> acc) in
- match f.cf_kind with
- | Var { v_write = AccCall } -> ("set_" ^ f.cf_name , "set_" ^ f.cf_name) :: acc
- | _ -> acc
+ if Meta.has Meta.Accessor f.cf_meta then
+ (f.cf_name, f.cf_name) :: acc
+ else
+ let acc = (match f.cf_kind with
+ | Var { v_read = AccCall } -> ("get_" ^ f.cf_name , "get_" ^ f.cf_name) :: acc
+ | _ -> acc) in
+ match f.cf_kind with
+ | Var { v_write = AccCall } -> ("set_" ^ f.cf_name , "set_" ^ f.cf_name) :: acc
+ | _ -> acc
) [] fields
let add_property_field com c =
@@ -119,6 +121,22 @@ let add_property_field com c =
c.cl_statics <- PMap.add cf.cf_name cf c.cl_statics;
c.cl_ordered_statics <- cf :: c.cl_ordered_statics
+let is_removable_field ctx f =
+ Meta.has Meta.Extern f.cf_meta || Meta.has Meta.Generic f.cf_meta
+ || (match f.cf_kind with
+ | Var {v_read = AccRequire (s,_)} -> true
+ | Method MethMacro -> not ctx.in_macro
+ | _ -> false)
+
+let escape_res_name name allow_dirs =
+ ExtString.String.replace_chars (fun chr ->
+ if (chr >= 'a' && chr <= 'z') || (chr >= 'A' && chr <= 'Z') || (chr >= '0' && chr <= '9') || chr = '_' || chr = '.' then
+ Char.escaped chr
+ else if chr = '/' && allow_dirs then
+ "/"
+ else
+ "-x" ^ (string_of_int (Char.code chr))) name
+
(* -------------------------------------------------------------------------- *)
(* REMOTING PROXYS *)
@@ -196,7 +214,7 @@ let extend_remoting ctx c t p async prot =
error ("Module " ^ s_type_path path ^ " does not define type " ^ t.tname) p
) in
match t with
- | TClassDecl c2 when c2.cl_types = [] -> c2.cl_build(); c.cl_super <- Some (c2,[]);
+ | TClassDecl c2 when c2.cl_params = [] -> ignore(c2.cl_build()); c.cl_super <- Some (c2,[]);
| _ -> error "Remoting proxy must be a class without parameters" p
(* -------------------------------------------------------------------------- *)
@@ -222,16 +240,19 @@ let make_generic ctx ps pt p =
in
let name =
String.concat "_" (List.map2 (fun (s,_) t ->
- let path = (match follow t with
- | TInst (ct,_) -> ct.cl_path
- | TEnum (e,_) -> e.e_path
- | TAbstract (a,_) when Meta.has Meta.RuntimeValue a.a_meta -> a.a_path
+ let s_type_path_underscore (p,s) = match p with [] -> s | _ -> String.concat "_" p ^ "_" ^ s in
+ let rec loop top t = match follow t with
+ | TInst(c,tl) -> (s_type_path_underscore c.cl_path) ^ (loop_tl tl)
+ | TEnum(en,tl) -> (s_type_path_underscore en.e_path) ^ (loop_tl tl)
+ | TAbstract(a,tl) -> (s_type_path_underscore a.a_path) ^ (loop_tl tl)
+ | _ when not top -> "_" (* allow unknown/incompatible types as type parameters to retain old behavior *)
| TMono _ -> raise (Generic_Exception (("Could not determine type for parameter " ^ s), p))
| t -> raise (Generic_Exception (("Type parameter must be a class or enum instance (found " ^ (s_type (print_context()) t) ^ ")"), p))
- ) in
- match path with
- | [] , name -> name
- | l , name -> String.concat "_" l ^ "_" ^ name
+ and loop_tl tl = match tl with
+ | [] -> ""
+ | tl -> "_" ^ String.concat "_" (List.map (loop false) tl)
+ in
+ loop true t
) ps pt)
in
{
@@ -251,7 +272,10 @@ let rec generic_substitute_type gctx t =
(match follow t,gctx.mg with TInst(c,_), Some m -> add_dependency m c.cl_module | _ -> ());
t
| _ ->
- try List.assq t gctx.subst with Not_found -> Type.map (generic_substitute_type gctx) t
+ try
+ generic_substitute_type gctx (List.assq t gctx.subst)
+ with Not_found ->
+ Type.map (generic_substitute_type gctx) t
let generic_substitute_expr gctx e =
let vars = Hashtbl.create 0 in
@@ -260,28 +284,21 @@ let generic_substitute_expr gctx e =
Hashtbl.find vars v.v_id
with Not_found ->
let v2 = alloc_var v.v_name (generic_substitute_type gctx v.v_type) in
+ v2.v_meta <- v.v_meta;
Hashtbl.add vars v.v_id v2;
v2
in
let rec build_expr e =
match e.eexpr with
- | TField(e1, FInstance({cl_kind = KGeneric},cf)) ->
- build_expr {e with eexpr = TField(e1,quick_field_dynamic (generic_substitute_type gctx (e1.etype)) cf.cf_name)}
- | _ -> map_expr_type build_expr (generic_substitute_type gctx) build_var e
+ | TField(e1, FInstance({cl_kind = KGeneric} as c,tl,cf)) ->
+ let _, _, f = gctx.ctx.g.do_build_instance gctx.ctx (TClassDecl c) gctx.p in
+ let t = f (List.map (generic_substitute_type gctx) tl) in
+ build_expr {e with eexpr = TField(e1,quick_field t cf.cf_name)}
+ | _ ->
+ map_expr_type build_expr (generic_substitute_type gctx) build_var e
in
build_expr e
-let is_generic_parameter ctx c =
- (* first check field parameters, then class parameters *)
- try
- ignore (List.assoc (snd c.cl_path) ctx.curfield.cf_params);
- Meta.has Meta.Generic ctx.curfield.cf_meta
- with Not_found -> try
- ignore(List.assoc (snd c.cl_path) ctx.type_params);
- (match ctx.curclass.cl_kind with | KGeneric -> true | _ -> false);
- with Not_found ->
- false
-
let has_ctor_constraint c = match c.cl_kind with
| KTypeParameter tl ->
List.exists (fun t -> match follow t with
@@ -290,6 +307,13 @@ let has_ctor_constraint c = match c.cl_kind with
) tl;
| _ -> false
+let get_short_name =
+ let i = ref (-1) in
+ (fun () ->
+ incr i;
+ Printf.sprintf "Hx___short___hx_type_%i" !i
+ )
+
let rec build_generic ctx c p tl =
let pack = fst c.cl_path in
let recurse = ref false in
@@ -298,7 +322,7 @@ let rec build_generic ctx c p tl =
| TInst (c2,tl) ->
(match c2.cl_kind with
| KTypeParameter tl ->
- if not (is_generic_parameter ctx c2) && has_ctor_constraint c2 then
+ if not (Typeload.is_generic_parameter ctx c2) && has_ctor_constraint c2 then
error "Type parameters with a constructor cannot be used non-generically" p;
recurse := true
| _ -> ());
@@ -307,16 +331,17 @@ let rec build_generic ctx c p tl =
()
in
List.iter check_recursive tl;
- let gctx = try make_generic ctx c.cl_types tl p with Generic_Exception (msg,p) -> error msg p in
- let name = (snd c.cl_path) ^ "_" ^ gctx.name in
if !recurse then begin
TInst (c,tl) (* build a normal instance *)
- end else try
+ end else begin
+ let gctx = make_generic ctx c.cl_params tl p in
+ let name = (snd c.cl_path) ^ "_" ^ gctx.name in
+ try
Typeload.load_instance ctx { tpackage = pack; tname = name; tparams = []; tsub = None } p false
with Error(Module_not_found path,_) when path = (pack,name) ->
let m = (try Hashtbl.find ctx.g.modules (Hashtbl.find ctx.g.types_module c.cl_path) with Not_found -> assert false) in
let ctx = { ctx with m = { ctx.m with module_types = m.m_types @ ctx.m.module_types } } in
- c.cl_build(); (* make sure the super class is already setup *)
+ ignore(c.cl_build()); (* make sure the super class is already setup *)
let mg = {
m_id = alloc_mid();
m_path = (pack,name);
@@ -358,34 +383,86 @@ let rec build_generic ctx c p tl =
List.iter loop tl
in
List.iter loop tl;
- let delays = ref [] in
- let build_field f =
- let t = generic_substitute_type gctx f.cf_type in
- let f = { f with cf_type = t} in
- (* delay the expression mapping to make sure all cf_type fields are set correctly first *)
- (delays := (fun () ->
- try (match f.cf_expr with None -> () | Some e -> f.cf_expr <- Some (generic_substitute_expr gctx e))
- with Unify_error l -> error (error_msg (Unify l)) f.cf_pos) :: !delays);
- f
+ let build_field cf_old =
+ let cf_new = {cf_old with cf_pos = cf_old.cf_pos} in (* copy *)
+ let f () =
+ let t = generic_substitute_type gctx cf_old.cf_type in
+ ignore (follow t);
+ begin try (match cf_old.cf_expr with
+ | None ->
+ begin match cf_old.cf_kind with
+ | Method _ when not c.cl_interface && not c.cl_extern ->
+ display_error ctx (Printf.sprintf "Field %s has no expression (possible typing order issue)" cf_new.cf_name) cf_new.cf_pos;
+ display_error ctx (Printf.sprintf "While building %s" (s_type_path cg.cl_path)) p;
+ | _ ->
+ ()
+ end
+ | Some e ->
+ cf_new.cf_expr <- Some (generic_substitute_expr gctx e)
+ ) with Unify_error l ->
+ error (error_msg (Unify l)) cf_new.cf_pos
+ end;
+ t
+ in
+ let r = exc_protect ctx (fun r ->
+ let t = mk_mono() in
+ r := (fun() -> t);
+ unify_raise ctx (f()) t p;
+ t
+ ) "build_generic" in
+ delay ctx PForce (fun() -> ignore ((!r)()));
+ cf_new.cf_type <- TLazy r;
+ cf_new
in
if c.cl_init <> None || c.cl_dynamic <> None then error "This class can't be generic" p;
- if c.cl_ordered_statics <> [] then error "A generic class can't have static fields" p;
+ List.iter (fun cf -> match cf.cf_kind with
+ | Method MethMacro when not ctx.in_macro -> ()
+ | _ -> error "A generic class can't have static fields" cf.cf_pos
+ ) c.cl_ordered_statics;
cg.cl_super <- (match c.cl_super with
| None -> None
| Some (cs,pl) ->
- (match apply_params c.cl_types tl (TInst (cs,pl)) with
- | TInst (cs,pl) when cs.cl_kind = KGeneric ->
+ let find_class subst =
+ let rec loop subst = match subst with
+ | (TInst(c,[]),t) :: subst when c == cs -> t
+ | _ :: subst -> loop subst
+ | [] -> raise Not_found
+ in
+ try
+ if pl <> [] then raise Not_found;
+ let t = loop subst in
+ (* extended type parameter: concrete type must have a constructor, but generic base class must not have one *)
+ begin match follow t,c.cl_constructor with
+ | TInst(cs,_),None ->
+ ignore(cs.cl_build());
+ begin match cs.cl_constructor with
+ | None -> error ("Cannot use " ^ (s_type_path cs.cl_path) ^ " as type parameter because it is extended and has no constructor") p
+ | _ -> ()
+ end;
+ | _,Some cf -> error "Generics extending type parameters cannot have constructors" cf.cf_pos
+ | _ -> ()
+ end;
+ t
+ with Not_found ->
+ apply_params c.cl_params tl (TInst(cs,pl))
+ in
+ let ts = follow (find_class gctx.subst) in
+ let cs,pl = Typeload.check_extends ctx c ts p in
+ match cs.cl_kind with
+ | KGeneric ->
(match build_generic ctx cs p pl with
| TInst (cs,pl) -> Some (cs,pl)
| _ -> assert false)
- | TInst (cs,pl) -> Some (cs,pl)
- | _ -> assert false)
+ | _ -> Some(cs,pl)
);
+ Typeload.add_constructor ctx cg false p;
cg.cl_kind <- KGenericInstance (c,tl);
+ cg.cl_meta <- (Meta.NoDoc,[],p) :: cg.cl_meta;
cg.cl_interface <- c.cl_interface;
- cg.cl_constructor <- (match c.cl_constructor, c.cl_super with
- | None, None -> None
- | Some c, _ -> Some (build_field c)
+ cg.cl_constructor <- (match cg.cl_constructor, c.cl_constructor, c.cl_super with
+ | _, Some cf, _ -> Some (build_field cf)
+ | Some ctor, _, _ -> Some ctor
+ | None, None, None -> None
| _ -> error "Please define a constructor for this class in order to use it as generic" c.cl_pos
);
cg.cl_implements <- List.map (fun (i,tl) ->
@@ -398,8 +475,13 @@ let rec build_generic ctx c p tl =
cg.cl_fields <- PMap.add f.cf_name f cg.cl_fields;
f
) c.cl_ordered_fields;
- List.iter (fun f -> f()) !delays;
+ (* In rare cases the class name can become too long, so let's shorten it (issue #3090). *)
+ if String.length (snd cg.cl_path) > 254 then begin
+ let n = get_short_name () in
+ cg.cl_meta <- (Meta.Native,[EConst(String (n)),p],p) :: cg.cl_meta;
+ end;
TInst (cg,[])
+ end
(* -------------------------------------------------------------------------- *)
(* HAXE.XML.PROXY *)
@@ -478,7 +560,7 @@ let build_metadata com t =
if Hashtbl.mem h f then error ("Duplicate metadata '" ^ f ^ "'") p;
Hashtbl.add h f ();
f, mk (match el with [] -> TConst TNull | _ -> TArrayDecl (List.map (type_constant_value com) el)) (api.tarray t_dynamic) p
- ) ml)) (api.tarray t_dynamic) p
+ ) ml)) t_dynamic p
in
let make_meta l =
mk (TObjectDecl (List.map (fun (f,ml) -> f,make_meta_field ml) l)) t_dynamic p
@@ -495,21 +577,38 @@ let build_metadata com t =
(* -------------------------------------------------------------------------- *)
(* MACRO TYPE *)
+let get_macro_path ctx e args p =
+ let rec loop e =
+ match fst e with
+ | EField (e,f) -> f :: loop e
+ | EConst (Ident i) -> [i]
+ | _ -> error "Invalid macro call" p
+ in
+ let path = match e with
+ | (EConst(Ident i)),_ ->
+ let path = try
+ if not (PMap.mem i ctx.curclass.cl_statics) then raise Not_found;
+ ctx.curclass.cl_path
+ with Not_found -> try
+ (t_infos (fst (PMap.find i ctx.m.module_globals))).mt_path
+ with Not_found ->
+ error "Invalid macro call" p
+ in
+ i :: (snd path) :: (fst path)
+ | _ ->
+ loop e
+ in
+ (match path with
+ | meth :: cl :: path -> (List.rev path,cl), meth, args
+ | _ -> error "Invalid macro call" p)
+
let build_macro_type ctx pl p =
let path, field, args = (match pl with
| [TInst ({ cl_kind = KExpr (ECall (e,args),_) },_)]
| [TInst ({ cl_kind = KExpr (EArrayDecl [ECall (e,args),_],_) },_)] ->
- let rec loop e =
- match fst e with
- | EField (e,f) -> f :: loop e
- | EConst (Ident i) -> [i]
- | _ -> error "Invalid macro call" p
- in
- (match loop e with
- | meth :: cl :: path -> (List.rev path,cl), meth, args
- | _ -> error "Invalid macro call" p)
+ get_macro_path ctx e args p
| _ ->
- error "MacroType require a single expression call parameter" p
+ error "MacroType requires a single expression call parameter" p
) in
let old = ctx.ret in
let t = (match ctx.g.do_macro ctx MMacroType path field args p with
@@ -519,43 +618,56 @@ let build_macro_type ctx pl p =
ctx.ret <- old;
t
+let build_macro_build ctx c pl cfl p =
+ let path, field, args = match Meta.get Meta.GenericBuild c.cl_meta with
+ | _,[ECall(e,args),_],_ -> get_macro_path ctx e args p
+ | _ -> error "genericBuild requires a single expression call parameter" p
+ in
+ let old = ctx.ret,ctx.g.get_build_infos in
+ ctx.g.get_build_infos <- (fun() -> Some (TClassDecl c, pl, cfl));
+ let t = (match ctx.g.do_macro ctx MMacroType path field args p with
+ | None -> mk_mono()
+ | Some _ -> ctx.ret
+ ) in
+ ctx.ret <- fst old;
+ ctx.g.get_build_infos <- snd old;
+ t
+
(* -------------------------------------------------------------------------- *)
(* API EVENTS *)
let build_instance ctx mtype p =
match mtype with
| TClassDecl c ->
- if ctx.pass > PBuildClass then c.cl_build();
+ if ctx.pass > PBuildClass then ignore(c.cl_build());
+ let build f s =
+ let r = exc_protect ctx (fun r ->
+ let t = mk_mono() in
+ r := (fun() -> t);
+ unify_raise ctx (f()) t p;
+ t
+ ) s in
+ delay ctx PForce (fun() -> ignore ((!r)()));
+ TLazy r
+ in
let ft = (fun pl ->
match c.cl_kind with
| KGeneric ->
- let r = exc_protect ctx (fun r ->
- let t = mk_mono() in
- r := (fun() -> t);
- unify_raise ctx (build_generic ctx c p pl) t p;
- t
- ) "build_generic" in
- delay ctx PForce (fun() -> ignore ((!r)()));
- TLazy r
+ build (fun () -> build_generic ctx c p pl) "build_generic"
| KMacroType ->
- let r = exc_protect ctx (fun r ->
- let t = mk_mono() in
- r := (fun() -> t);
- unify_raise ctx (build_macro_type ctx pl p) t p;
- t
- ) "macro_type" in
- delay ctx PForce (fun() -> ignore ((!r)()));
- TLazy r
+ build (fun () -> build_macro_type ctx pl p) "macro_type"
+ | KGenericBuild cfl ->
+ build (fun () -> build_macro_build ctx c pl cfl p) "generic_build"
| _ ->
TInst (c,pl)
) in
- c.cl_types , c.cl_path , ft
+ c.cl_params , c.cl_path , ft
| TEnumDecl e ->
- e.e_types , e.e_path , (fun t -> TEnum (e,t))
+ e.e_params , e.e_path , (fun t -> TEnum (e,t))
| TTypeDecl t ->
- t.t_types , t.t_path , (fun tl -> TType(t,tl))
+ t.t_params , t.t_path , (fun tl -> TType(t,tl))
| TAbstractDecl a ->
- a.a_types, a.a_path, (fun tl -> TAbstract(a,tl))
+ a.a_params, a.a_path, (fun tl -> TAbstract(a,tl))
let on_inherit ctx c p h =
match h with
@@ -565,804 +677,23 @@ let on_inherit ctx c p h =
| HExtends { tpackage = ["haxe";"remoting"]; tname = "AsyncProxy"; tparams = [TPType(CTPath t)] } ->
extend_remoting ctx c t p true true;
false
- | HExtends { tpackage = ["mt"]; tname = "AsyncProxy"; tparams = [TPType(CTPath t)] } ->
- extend_remoting ctx c t p true false;
- false
| HExtends { tpackage = ["haxe";"xml"]; tname = "Proxy"; tparams = [TPExpr(EConst (String file),p);TPType t] } ->
extend_xml_proxy ctx c t file p;
true
| _ ->
true
-(* -------------------------------------------------------------------------- *)
-(* FINAL GENERATION *)
-
-(* Saves a class state so it can be restored later, e.g. after DCE or native path rewrite *)
-let save_class_state ctx t = match t with
- | TClassDecl c ->
- let meta = c.cl_meta and path = c.cl_path and ext = c.cl_extern in
- let fl = c.cl_fields and ofl = c.cl_ordered_fields and st = c.cl_statics and ost = c.cl_ordered_statics in
- let cst = c.cl_constructor and over = c.cl_overrides in
- let oflk = List.map (fun f -> f.cf_kind,f.cf_expr,f.cf_type) ofl in
- let ostk = List.map (fun f -> f.cf_kind,f.cf_expr,f.cf_type) ost in
- c.cl_restore <- (fun() ->
- c.cl_meta <- meta;
- c.cl_extern <- ext;
- c.cl_path <- path;
- c.cl_fields <- fl;
- c.cl_ordered_fields <- ofl;
- c.cl_statics <- st;
- c.cl_ordered_statics <- ost;
- c.cl_constructor <- cst;
- c.cl_overrides <- over;
- (* DCE might modify the cf_kind, so let's restore it as well *)
- List.iter2 (fun f (k,e,t) -> f.cf_kind <- k; f.cf_expr <- e; f.cf_type <- t;) ofl oflk;
- List.iter2 (fun f (k,e,t) -> f.cf_kind <- k; f.cf_expr <- e; f.cf_type <- t;) ost ostk;
- )
- | _ ->
- ()
-
-
-(* Checks if a private class' path clashes with another path *)
-let check_private_path ctx t = match t with
- | TClassDecl c when c.cl_private ->
- let rpath = (fst c.cl_module.m_path,"_" ^ snd c.cl_module.m_path) in
- if Hashtbl.mem ctx.g.types_module rpath then error ("This private class name will clash with " ^ s_type_path rpath) c.cl_pos;
- | _ ->
- ()
-
-(* Removes generic base classes *)
-let remove_generic_base ctx t = match t with
- | TClassDecl c when c.cl_kind = KGeneric && has_ctor_constraint c ->
- c.cl_extern <- true
- | _ ->
- ()
-
-(* Rewrites class or enum paths if @:native metadata is set *)
-let apply_native_paths ctx t =
- let get_real_path meta path =
- let (_,e,mp) = Meta.get Meta.Native meta in
- match e with
- | [Ast.EConst (Ast.String name),p] ->
- (Meta.RealPath,[Ast.EConst (Ast.String (s_type_path path)),p],mp),parse_path name
- | _ ->
- error "String expected" mp
- in
- try
- (match t with
- | TClassDecl c ->
- let meta,path = get_real_path c.cl_meta c.cl_path in
- c.cl_meta <- meta :: c.cl_meta;
- c.cl_path <- path;
- | TEnumDecl e ->
- let meta,path = get_real_path e.e_meta e.e_path in
- e.e_meta <- meta :: e.e_meta;
- e.e_path <- path;
- | _ ->
- ())
- with Not_found ->
- ()
-
-(* Adds the __rtti field if required *)
-let add_rtti ctx t =
- let rec has_rtti c =
- Meta.has Meta.Rtti c.cl_meta || match c.cl_super with None -> false | Some (csup,_) -> has_rtti csup
- in
- match t with
- | TClassDecl c when has_rtti c && not (PMap.mem "__rtti" c.cl_statics) ->
- let f = mk_field "__rtti" ctx.t.tstring c.cl_pos in
- let str = Genxml.gen_type_string ctx.com t in
- f.cf_expr <- Some (mk (TConst (TString str)) f.cf_type c.cl_pos);
- c.cl_ordered_statics <- f :: c.cl_ordered_statics;
- c.cl_statics <- PMap.add f.cf_name f c.cl_statics;
- | _ ->
- ()
-
-(* Removes extern and macro fields, also checks for Void fields *)
-let remove_extern_fields ctx t = match t with
- | TClassDecl c ->
- let do_remove f =
- Meta.has Meta.Extern f.cf_meta || Meta.has Meta.Generic f.cf_meta
- || (match f.cf_kind with
- | Var {v_read = AccRequire (s,_)} -> true
- | Method MethMacro -> not ctx.in_macro
- | _ -> false)
- in
- if not (Common.defined ctx.com Define.DocGen) then begin
- c.cl_ordered_fields <- List.filter (fun f ->
- let b = do_remove f in
- if b then c.cl_fields <- PMap.remove f.cf_name c.cl_fields;
- not b
- ) c.cl_ordered_fields;
- c.cl_ordered_statics <- List.filter (fun f ->
- let b = do_remove f in
- if b then c.cl_statics <- PMap.remove f.cf_name c.cl_statics;
- not b
- ) c.cl_ordered_statics;
- end
- | _ ->
- ()
-
-(* Adds member field initializations as assignments to the constructor *)
-let add_field_inits ctx t =
- let apply c =
- let ethis = mk (TConst TThis) (TInst (c,List.map snd c.cl_types)) c.cl_pos in
- (* TODO: we have to find a variable name which is not used in any of the functions *)
- let v = alloc_var "_g" ethis.etype in
- let need_this = ref false in
- let inits,fields = List.fold_left (fun (inits,fields) cf ->
- match cf.cf_kind,cf.cf_expr with
- | Var _, Some _ ->
- if ctx.com.config.pf_can_init_member cf then (inits, cf :: fields) else (cf :: inits, cf :: fields)
- | Method MethDynamic, Some e when Common.defined ctx.com Define.As3 ->
- (* TODO : this would have a better place in genSWF9 I think - NC *)
- (* we move the initialization of dynamic functions to the constructor and also solve the
- 'this' problem along the way *)
- let rec use_this v e = match e.eexpr with
- | TConst TThis ->
- need_this := true;
- mk (TLocal v) v.v_type e.epos
- | _ -> Type.map_expr (use_this v) e
- in
- let e = Type.map_expr (use_this v) e in
- let cf2 = {cf with cf_expr = Some e} in
- (* if the method is an override, we have to remove the class field to not get invalid overrides *)
- let fields = if List.memq cf c.cl_overrides then begin
- c.cl_fields <- PMap.remove cf.cf_name c.cl_fields;
- fields
- end else
- cf2 :: fields
- in
- (cf2 :: inits, fields)
- | _ -> (inits, cf :: fields)
- ) ([],[]) c.cl_ordered_fields in
- c.cl_ordered_fields <- fields;
- match inits with
- | [] -> ()
- | _ ->
- let el = List.map (fun cf ->
- match cf.cf_expr with
- | None -> assert false
- | Some e ->
- let lhs = mk (TField(ethis,FInstance (c,cf))) cf.cf_type e.epos in
- cf.cf_expr <- None;
- let eassign = mk (TBinop(OpAssign,lhs,e)) e.etype e.epos in
- if Common.defined ctx.com Define.As3 then begin
- let echeck = mk (TBinop(OpEq,lhs,(mk (TConst TNull) lhs.etype e.epos))) ctx.com.basic.tbool e.epos in
- mk (TIf(echeck,eassign,None)) eassign.etype e.epos
- end else
- eassign;
- ) inits in
- let el = if !need_this then (mk (TVars([v, Some ethis])) ethis.etype ethis.epos) :: el else el in
- match c.cl_constructor with
- | None ->
- let ct = TFun([],ctx.com.basic.tvoid) in
- let ce = mk (TFunction {
- tf_args = [];
- tf_type = ctx.com.basic.tvoid;
- tf_expr = mk (TBlock el) ctx.com.basic.tvoid c.cl_pos;
- }) ct c.cl_pos in
- let ctor = mk_field "new" ct c.cl_pos in
- ctor.cf_kind <- Method MethNormal;
- c.cl_constructor <- Some { ctor with cf_expr = Some ce };
- | Some cf ->
- match cf.cf_expr with
- | Some { eexpr = TFunction f } ->
- let bl = match f.tf_expr with {eexpr = TBlock b } -> b | x -> [x] in
- let ce = mk (TFunction {f with tf_expr = mk (TBlock (el @ bl)) ctx.com.basic.tvoid c.cl_pos }) cf.cf_type cf.cf_pos in
- c.cl_constructor <- Some {cf with cf_expr = Some ce }
- | _ ->
- assert false
- in
- match t with
- | TClassDecl c ->
- apply c
- | _ ->
- ()
-
-(* Adds the __meta__ field if required *)
-let add_meta_field ctx t = match t with
- | TClassDecl c ->
- (match build_metadata ctx.com t with
- | None -> ()
- | Some e ->
- let f = mk_field "__meta__" t_dynamic c.cl_pos in
- f.cf_expr <- Some e;
- c.cl_ordered_statics <- f :: c.cl_ordered_statics;
- c.cl_statics <- PMap.add f.cf_name f c.cl_statics)
- | _ ->
- ()
-
-(* Removes interfaces tagged with @:remove metadata *)
-let check_remove_metadata ctx t = match t with
- | TClassDecl c ->
- c.cl_implements <- List.filter (fun (c,_) -> not (Meta.has Meta.Remove c.cl_meta)) c.cl_implements;
- | _ ->
- ()
-
-(* Checks for Void class fields *)
-let check_void_field ctx t = match t with
- | TClassDecl c ->
- let check f =
- match follow f.cf_type with TAbstract({a_path=[],"Void"},_) -> error "Fields of type Void are not allowed" f.cf_pos | _ -> ();
- in
- List.iter check c.cl_ordered_fields;
- List.iter check c.cl_ordered_statics;
- | _ ->
- ()
-
-(* Promotes type parameters of abstracts to their implementation fields *)
-let promote_abstract_parameters ctx t = match t with
- | TClassDecl ({cl_kind = KAbstractImpl a} as c) when a.a_types <> [] ->
- List.iter (fun f ->
- List.iter (fun (n,t) -> match t with
- | TInst({cl_kind = KTypeParameter _; cl_path=p,n} as cp,[]) when not (List.mem_assoc n f.cf_params) ->
- let path = List.rev ((snd c.cl_path) :: List.rev (fst c.cl_path)),n in
- f.cf_params <- (n,TInst({cp with cl_path = path},[])) :: f.cf_params
- | _ ->
- ()
- ) a.a_types;
- ) c.cl_ordered_statics;
- | _ ->
- ()
-
-(* -------------------------------------------------------------------------- *)
-(* LOCAL VARIABLES USAGE *)
-
-type usage =
- | Block of ((usage -> unit) -> unit)
- | Loop of ((usage -> unit) -> unit)
- | Function of ((usage -> unit) -> unit)
- | Declare of tvar
- | Use of tvar
-
-let rec local_usage f e =
- match e.eexpr with
- | TLocal v ->
- f (Use v)
- | TVars l ->
- List.iter (fun (v,e) ->
- (match e with None -> () | Some e -> local_usage f e);
- f (Declare v);
- ) l
- | TFunction tf ->
- let cc f =
- List.iter (fun (v,_) -> f (Declare v)) tf.tf_args;
- local_usage f tf.tf_expr;
- in
- f (Function cc)
- | TBlock l ->
- f (Block (fun f -> List.iter (local_usage f) l))
- | TFor (v,it,e) ->
- local_usage f it;
- f (Loop (fun f ->
- f (Declare v);
- local_usage f e;
- ))
- | TWhile _ ->
- f (Loop (fun f ->
- iter (local_usage f) e
- ))
- | TTry (e,catchs) ->
- local_usage f e;
- List.iter (fun (v,e) ->
- f (Block (fun f ->
- f (Declare v);
- local_usage f e;
- ))
- ) catchs;
- | TMatch (e,_,cases,def) ->
- local_usage f e;
- List.iter (fun (_,vars,e) ->
- let cc f =
- (match vars with
- | None -> ()
- | Some l -> List.iter (function None -> () | Some v -> f (Declare v)) l);
- local_usage f e;
- in
- f (Block cc)
- ) cases;
- (match def with None -> () | Some e -> local_usage f e);
- | _ ->
- iter (local_usage f) e
-
-(* -------------------------------------------------------------------------- *)
-(* BLOCK VARIABLES CAPTURE *)
-
-(*
- For some platforms, it will simply mark the variables which are used in closures
- using the v_capture flag so it can be processed in a more optimized
-
- For Flash/JS platforms, it will ensure that variables used in loop sub-functions
- have an unique scope. It transforms the following expression :
-
- for( x in array )
- funs.push(function() return x++);
-
- Into the following :
-
- for( _x in array ) {
- var x = [_x];
- funs.push(function(x) { function() return x[0]++; }(x));
- }
-*)
-
-let captured_vars com e =
-
- let t = com.basic in
-
- let rec mk_init av v pos =
- mk (TVars [av,Some (mk (TArrayDecl [mk (TLocal v) v.v_type pos]) av.v_type pos)]) t.tvoid pos
-
- and mk_var v used =
- alloc_var v.v_name (PMap.find v.v_id used)
-
- and wrap used e =
- match e.eexpr with
- | TVars vl ->
- let vl = List.map (fun (v,ve) ->
- if PMap.mem v.v_id used then
- v, Some (mk (TArrayDecl (match ve with None -> [] | Some e -> [wrap used e])) v.v_type e.epos)
- else
- v, (match ve with None -> None | Some e -> Some (wrap used e))
- ) vl in
- { e with eexpr = TVars vl }
- | TLocal v when PMap.mem v.v_id used ->
- mk (TArray ({ e with etype = v.v_type },mk (TConst (TInt 0l)) t.tint e.epos)) e.etype e.epos
- | TFor (v,it,expr) when PMap.mem v.v_id used ->
- let vtmp = mk_var v used in
- let it = wrap used it in
- let expr = wrap used expr in
- mk (TFor (vtmp,it,concat (mk_init v vtmp e.epos) expr)) e.etype e.epos
- | TTry (expr,catchs) ->
- let catchs = List.map (fun (v,e) ->
- let e = wrap used e in
- try
- let vtmp = mk_var v used in
- vtmp, concat (mk_init v vtmp e.epos) e
- with Not_found ->
- v, e
- ) catchs in
- mk (TTry (wrap used expr,catchs)) e.etype e.epos
- | TMatch (expr,enum,cases,def) ->
- let cases = List.map (fun (il,vars,e) ->
- let pos = e.epos in
- let e = ref (wrap used e) in
- let vars = match vars with
- | None -> None
- | Some l ->
- Some (List.map (fun v ->
- match v with
- | Some v when PMap.mem v.v_id used ->
- let vtmp = mk_var v used in
- e := concat (mk_init v vtmp pos) !e;
- Some vtmp
- | _ -> v
- ) l)
- in
- il, vars, !e
- ) cases in
- let def = match def with None -> None | Some e -> Some (wrap used e) in
- mk (TMatch (wrap used expr,enum,cases,def)) e.etype e.epos
- | TFunction f ->
- (*
- list variables that are marked as used, but also used in that
- function and which are not declared inside it !
- *)
- let fused = ref PMap.empty in
- let tmp_used = ref used in
- let rec browse = function
- | Block f | Loop f | Function f -> f browse
- | Use v ->
- if PMap.mem v.v_id !tmp_used then fused := PMap.add v.v_id v !fused;
- | Declare v ->
- tmp_used := PMap.remove v.v_id !tmp_used
- in
- local_usage browse e;
- let vars = PMap.fold (fun v acc -> v :: acc) !fused [] in
-
- (* in case the variable has been marked as used in a parallel scope... *)
- let fexpr = ref (wrap used f.tf_expr) in
- let fargs = List.map (fun (v,o) ->
- if PMap.mem v.v_id used then
- let vtmp = mk_var v used in
- fexpr := concat (mk_init v vtmp e.epos) !fexpr;
- vtmp, o
- else
- v, o
- ) f.tf_args in
- let e = { e with eexpr = TFunction { f with tf_args = fargs; tf_expr = !fexpr } } in
- (*
- Create a new function scope to make sure that the captured loop variable
- will not be overwritten in next loop iteration
- *)
- if com.config.pf_capture_policy = CPLoopVars then
- mk (TCall (
- mk_parent (mk (TFunction {
- tf_args = List.map (fun v -> v, None) vars;
- tf_type = e.etype;
- tf_expr = mk_block (mk (TReturn (Some e)) e.etype e.epos);
- }) (TFun (List.map (fun v -> v.v_name,false,v.v_type) vars,e.etype)) e.epos),
- List.map (fun v -> mk (TLocal v) v.v_type e.epos) vars)
- ) e.etype e.epos
- else
- e
- | _ ->
- map_expr (wrap used) e
-
- and do_wrap used e =
- if PMap.is_empty used then
- e
- else
- let used = PMap.map (fun v ->
- let vt = v.v_type in
- v.v_type <- t.tarray vt;
- v.v_capture <- true;
- vt
- ) used in
- wrap used e
-
- and out_loop e =
- match e.eexpr with
- | TFor _ | TWhile _ ->
- (*
- collect variables that are declared in loop but used in subfunctions
- *)
- let vars = ref PMap.empty in
- let used = ref PMap.empty in
- let depth = ref 0 in
- let rec collect_vars in_loop = function
- | Block f ->
- let old = !vars in
- f (collect_vars in_loop);
- vars := old;
- | Loop f ->
- let old = !vars in
- f (collect_vars true);
- vars := old;
- | Function f ->
- incr depth;
- f (collect_vars false);
- decr depth;
- | Declare v ->
- if in_loop then vars := PMap.add v.v_id !depth !vars;
- | Use v ->
- try
- let d = PMap.find v.v_id !vars in
- if d <> !depth then used := PMap.add v.v_id v !used;
- with Not_found ->
- ()
- in
- local_usage (collect_vars false) e;
- do_wrap !used e
- | _ ->
- map_expr out_loop e
- and all_vars e =
- let vars = ref PMap.empty in
- let used = ref PMap.empty in
- let depth = ref 0 in
- let rec collect_vars = function
- | Block f ->
- let old = !vars in
- f collect_vars;
- vars := old;
- | Loop f ->
- let old = !vars in
- f collect_vars;
- vars := old;
- | Function f ->
- incr depth;
- f collect_vars;
- decr depth;
- | Declare v ->
- vars := PMap.add v.v_id !depth !vars;
- | Use v ->
- try
- let d = PMap.find v.v_id !vars in
- if d <> !depth then used := PMap.add v.v_id v !used;
- with Not_found -> ()
- in
- local_usage collect_vars e;
- !used
- in
- (* mark all capture variables - also used in rename_local_vars at later stage *)
- let captured = all_vars e in
- PMap.iter (fun _ v -> v.v_capture <- true) captured;
- match com.config.pf_capture_policy with
- | CPNone -> e
- | CPWrapRef -> do_wrap captured e
- | CPLoopVars -> out_loop e
-
-(* -------------------------------------------------------------------------- *)
-(* RENAME LOCAL VARS *)
-
-let rename_local_vars com e =
- let cfg = com.config in
- let all_scope = (not cfg.pf_captured_scope) || (not cfg.pf_locals_scope) in
- let vars = ref PMap.empty in
- let all_vars = ref PMap.empty in
- let vtemp = alloc_var "~" t_dynamic in
- let rebuild_vars = ref false in
- let rebuild m =
- PMap.fold (fun v acc -> PMap.add v.v_name v acc) m PMap.empty
- in
- let save() =
- let old = !vars in
- if cfg.pf_unique_locals then (fun() -> ()) else (fun() -> vars := if !rebuild_vars then rebuild old else old)
- in
- let rename vars v =
- let count = ref 1 in
- while PMap.mem (v.v_name ^ string_of_int !count) vars do
- incr count;
- done;
- v.v_name <- v.v_name ^ string_of_int !count;
- in
- let declare v p =
- (match follow v.v_type with
- | TAbstract ({a_path = [],"Void"},_) -> error "Arguments and variables of type Void are not allowed" p
- | _ -> ());
- (* chop escape char for all local variables generated *)
- if String.unsafe_get v.v_name 0 = String.unsafe_get gen_local_prefix 0 then v.v_name <- "_g" ^ String.sub v.v_name 1 (String.length v.v_name - 1);
- let look_vars = (if not cfg.pf_captured_scope && v.v_capture then !all_vars else !vars) in
- (try
- let v2 = PMap.find v.v_name look_vars in
- (*
- block_vars will create some wrapper-functions that are declaring
- the same variable twice. In that case do not perform a rename since
- we are sure it's actually the same variable
- *)
- if v == v2 then raise Not_found;
- rename look_vars v;
- with Not_found ->
- ());
- vars := PMap.add v.v_name v !vars;
- if all_scope then all_vars := PMap.add v.v_name v !all_vars;
- in
- (*
- This is quite a rare case, when a local variable would otherwise prevent
- accessing a type because it masks the type value or the package name.
- *)
- let check t =
- match (t_infos t).mt_path with
- | [], name | name :: _, _ ->
- let vars = if cfg.pf_locals_scope then vars else all_vars in
- (try
- let v = PMap.find name !vars in
- if v == vtemp then raise Not_found; (* ignore *)
- rename (!vars) v;
- rebuild_vars := true;
- vars := PMap.add v.v_name v !vars
- with Not_found ->
- ());
- vars := PMap.add name vtemp !vars
- in
- let check_type t =
- match follow t with
- | TInst (c,_) -> check (TClassDecl c)
- | TEnum (e,_) -> check (TEnumDecl e)
- | TType (t,_) -> check (TTypeDecl t)
- | TAbstract (a,_) -> check (TAbstractDecl a)
- | TMono _ | TLazy _ | TAnon _ | TDynamic _ | TFun _ -> ()
- in
- let rec loop e =
- match e.eexpr with
- | TVars l ->
- List.iter (fun (v,eo) ->
- if not cfg.pf_locals_scope then declare v e.epos;
- (match eo with None -> () | Some e -> loop e);
- if cfg.pf_locals_scope then declare v e.epos;
- ) l
- | TFunction tf ->
- let old = save() in
- List.iter (fun (v,_) -> declare v e.epos) tf.tf_args;
- loop tf.tf_expr;
- old()
- | TBlock el ->
- let old = save() in
- List.iter loop el;
- old()
- | TFor (v,it,e1) ->
- loop it;
- let old = save() in
- declare v e.epos;
- loop e1;
- old()
- | TTry (e,catchs) ->
- loop e;
- List.iter (fun (v,e) ->
- let old = save() in
- declare v e.epos;
- check_type v.v_type;
- loop e;
- old()
- ) catchs;
- | TMatch (e,_,cases,def) ->
- loop e;
- List.iter (fun (_,vars,e) ->
- let old = save() in
- (match vars with
- | None -> ()
- | Some l -> List.iter (function None -> () | Some v -> declare v e.epos) l);
- loop e;
- old();
- ) cases;
- (match def with None -> () | Some e -> loop e);
- | TTypeExpr t ->
- check t
- | TNew (c,_,_) ->
- Type.iter loop e;
- check (TClassDecl c);
- | TCast (e,Some t) ->
- loop e;
- check t;
- | _ ->
- Type.iter loop e
- in
- declare (alloc_var "this" t_dynamic) Ast.null_pos; (* force renaming of 'this' vars in abstract *)
- loop e;
- e
-
-(* -------------------------------------------------------------------------- *)
-(* CHECK LOCAL VARS INIT *)
-
-let check_local_vars_init e =
- let intersect vl1 vl2 =
- PMap.mapi (fun v t -> t && PMap.find v vl2) vl1
- in
- let join vars cvars =
- List.iter (fun v -> vars := intersect !vars v) cvars
- in
- let restore vars old_vars declared =
- (* restore variables declared in this block to their previous state *)
- vars := List.fold_left (fun acc v ->
- try PMap.add v (PMap.find v old_vars) acc with Not_found -> PMap.remove v acc
- ) !vars declared;
- in
- let declared = ref [] in
- let rec loop vars e =
- match e.eexpr with
- | TLocal v ->
- let init = (try PMap.find v.v_id !vars with Not_found -> true) in
- if not init then begin
- if v.v_name = "this" then error "Missing this = value" e.epos
- else error ("Local variable " ^ v.v_name ^ " used without being initialized") e.epos
- end
- | TVars vl ->
- List.iter (fun (v,eo) ->
- match eo with
- | None ->
- declared := v.v_id :: !declared;
- vars := PMap.add v.v_id false !vars
- | Some e ->
- loop vars e
- ) vl
- | TBlock el ->
- let old = !declared in
- let old_vars = !vars in
- declared := [];
- List.iter (loop vars) el;
- restore vars old_vars (List.rev !declared);
- declared := old;
- | TBinop (OpAssign,{ eexpr = TLocal v },e) when PMap.mem v.v_id !vars ->
- loop vars e;
- vars := PMap.add v.v_id true !vars
- | TIf (e1,e2,eo) ->
- loop vars e1;
- let vbase = !vars in
- loop vars e2;
- (match eo with
- | None -> vars := vbase
- | Some e ->
- let v1 = !vars in
- vars := vbase;
- loop vars e;
- vars := intersect !vars v1)
- | TWhile (cond,e,flag) ->
- (match flag with
- | NormalWhile ->
- loop vars cond;
- let old = !vars in
- loop vars e;
- vars := old;
- | DoWhile ->
- loop vars e;
- loop vars cond)
- | TTry (e,catches) ->
- let cvars = List.map (fun (v,e) ->
- let old = !vars in
- loop vars e;
- let v = !vars in
- vars := old;
- v
- ) catches in
- loop vars e;
- join vars cvars;
- | TSwitch (e,cases,def) ->
- loop vars e;
- let cvars = List.map (fun (ec,e) ->
- let old = !vars in
- List.iter (loop vars) ec;
- vars := old;
- loop vars e;
- let v = !vars in
- vars := old;
- v
- ) cases in
- (match def with
- | None -> ()
- | Some e ->
- loop vars e;
- join vars cvars)
- | TMatch (e,_,cases,def) ->
- loop vars e;
- let old = !vars in
- let cvars = List.map (fun (_,vl,e) ->
- vars := old;
- loop vars e;
- restore vars old [];
- !vars
- ) cases in
- (match def with None -> () | Some e -> vars := old; loop vars e);
- join vars cvars
- (* mark all reachable vars as initialized, since we don't exit the block *)
- | TBreak | TContinue | TReturn None ->
- vars := PMap.map (fun _ -> true) !vars
- | TThrow e | TReturn (Some e) ->
- loop vars e;
- vars := PMap.map (fun _ -> true) !vars
- | _ ->
- Type.iter (loop vars) e
- in
- loop (ref PMap.empty) e;
- e
-
(* -------------------------------------------------------------------------- *)
(* ABSTRACT CASTS *)
-module Abstract = struct
-
- let find_to ab pl b = List.find (Type.unify_to_field ab pl b) ab.a_to
- let find_from ab pl a b = List.find (Type.unify_from_field ab pl a b) ab.a_from
+module AbstractCast = struct
let cast_stack = ref []
- let get_underlying_type a pl =
- try
- if not (Meta.has Meta.MultiType a.a_meta) then raise Not_found;
- let m = mk_mono() in
- let _ = find_to a pl m in
- follow m
- with Not_found ->
- apply_params a.a_types pl a.a_this
-
- let rec make_static_call ctx c cf a pl args t p =
- let ta = TAnon { a_fields = c.cl_statics; a_status = ref (Statics c) } in
- let ethis = mk (TTypeExpr (TClassDecl c)) ta p in
- let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
- let map t = apply_params a.a_types pl (apply_params cf.cf_params monos t) in
- let tcf = match follow (map cf.cf_type),args with
- | TFun((_,_,ta) :: args,r) as tf,e :: el when Meta.has Meta.From cf.cf_meta ->
- unify ctx e.etype ta p;
- tf
- | t,_ -> t
- in
- let def () =
- let e = mk (TField (ethis,(FStatic (c,cf)))) tcf p in
- loop ctx (mk (TCall(e,args)) (map t) p)
- in
- match cf.cf_expr with
- | Some { eexpr = TFunction fd } when cf.cf_kind = Method MethInline ->
- let config = if Meta.has Meta.Impl cf.cf_meta then (Some (a.a_types <> [] || cf.cf_params <> [], map)) else None in
- (match Optimizer.type_inline ctx cf fd ethis args t config p true with
- | Some e -> (match e.eexpr with TCast(e,None) -> e | _ -> e)
- | None -> def())
- | _ ->
- def()
+ let make_static_call ctx c cf a pl args t p =
+ make_static_call ctx c cf (apply_params a.a_params pl) args t p
- and check_cast ctx tleft eright p =
- let tright = follow eright.etype in
- let tleft = follow tleft in
- if tleft == tright then eright else
+ let do_check_cast ctx tleft eright p =
let recurse cf f =
if cf == ctx.curfield || List.mem cf !cast_stack then error "Recursive implicit cast" p;
cast_stack := cf :: !cast_stack;
@@ -1370,167 +701,361 @@ module Abstract = struct
cast_stack := List.tl !cast_stack;
r
in
- try (match tright,tleft with
- | (TAbstract({a_impl = Some c1} as a1,pl1) as t1),(TAbstract({a_impl = Some c2} as a2,pl2) as t2) ->
- if a1 == a2 then
- eright
- else begin
- let c,cfo,a,pl = try
- if Meta.has Meta.MultiType a1.a_meta then raise Not_found;
- c1,snd (find_to a1 pl1 t2),a1,pl1
- with Not_found ->
- if Meta.has Meta.MultiType a2.a_meta then raise Not_found;
- c2,snd (find_from a2 pl2 t1 t2),a2,pl2
- in
- match cfo with
- | None -> eright
- | Some cf ->
- recurse cf (fun () -> make_static_call ctx c cf a pl [eright] tleft p)
+ let find a tl f =
+ let tcf,cf = f() in
+ if (Meta.has Meta.MultiType a.a_meta) then
+ mk_cast eright tleft p
+ else match a.a_impl with
+ | Some c -> recurse cf (fun () ->
+ let ret = make_static_call ctx c cf a tl [eright] tleft p in
+ { ret with eexpr = TMeta( (Meta.ImplicitCast,[],ret.epos), ret) }
+ )
+ | None -> assert false
+ in
+ if type_iseq tleft eright.etype then
+ eright
+ else begin
+ let rec loop tleft tright = match follow tleft,follow tright with
+ | TAbstract(a1,tl1),TAbstract(a2,tl2) ->
+ begin try find a2 tl2 (fun () -> Abstract.find_to a2 tl2 tleft)
+ with Not_found -> try find a1 tl1 (fun () -> Abstract.find_from a1 tl1 eright.etype tleft)
+ with Not_found -> raise Not_found
end
- | TDynamic _,_ | _,TDynamic _ ->
- eright
- | TAbstract({a_impl = Some c} as a,pl),t2 when not (Meta.has Meta.MultiType a.a_meta) ->
- begin match find_to a pl t2 with
- | tcf,None ->
- let tcf = apply_params a.a_types pl tcf in
- if type_iseq tcf tleft then eright else check_cast ctx tcf eright p
- | _,Some cf ->
- recurse cf (fun () -> make_static_call ctx c cf a pl [eright] tleft p)
+ | TAbstract(a,tl),_ ->
+ begin try find a tl (fun () -> Abstract.find_from a tl eright.etype tleft)
+ with Not_found ->
+ let rec loop2 tcl = match tcl with
+ | tc :: tcl ->
+ if not (type_iseq tc tleft) then loop (apply_params a.a_params tl tc) tright
+ else loop2 tcl
+ | [] -> raise Not_found
+ in
+ loop2 a.a_from
end
- | t1,(TAbstract({a_impl = Some c} as a,pl) as t2) when not (Meta.has Meta.MultiType a.a_meta) ->
- begin match find_from a pl t1 t2 with
- | tcf,None ->
- let tcf = apply_params a.a_types pl tcf in
- if type_iseq tcf tleft then eright else check_cast ctx tcf eright p
- | _,Some cf ->
- recurse cf (fun () -> make_static_call ctx c cf a pl [eright] tleft p)
+ | _,TAbstract(a,tl) ->
+ begin try find a tl (fun () -> Abstract.find_to a tl tleft)
+ with Not_found ->
+ let rec loop2 tcl = match tcl with
+ | tc :: tcl ->
+ if not (type_iseq tc tright) then loop tleft (apply_params a.a_params tl tc)
+ else loop2 tcl
+ | [] -> raise Not_found
+ in
+ loop2 a.a_to
end
| _ ->
- eright)
+ raise Not_found
+ in
+ loop tleft eright.etype
+ end
+
+ let cast_or_unify_raise ctx tleft eright p =
+ try
+ if ctx.com.display <> DMNone then raise Not_found;
+ do_check_cast ctx tleft eright p
with Not_found ->
+ unify_raise ctx eright.etype tleft p;
eright
- and call_args ctx el tl = match el,tl with
- | [],_ -> []
- | e :: el, [] -> (loop ctx e) :: call_args ctx el []
- | e :: el, (_,_,t) :: tl ->
- (check_cast ctx t (loop ctx e) e.epos) :: call_args ctx el tl
-
- and loop ctx e = match e.eexpr with
- | TBinop(OpAssign,e1,e2) ->
- let e2 = check_cast ctx e1.etype (loop ctx e2) e.epos in
- { e with eexpr = TBinop(OpAssign,loop ctx e1,e2) }
- | TVars vl ->
- let vl = List.map (fun (v,eo) -> match eo with
- | None -> (v,eo)
- | Some e ->
- let is_generic_abstract = match e.etype with TAbstract ({a_impl = Some _} as a,_) -> Meta.has Meta.MultiType a.a_meta | _ -> false in
- let e = check_cast ctx v.v_type (loop ctx e) e.epos in
- (* we can rewrite this for better field inference *)
- if is_generic_abstract then v.v_type <- e.etype;
- v, Some e
- ) vl in
- { e with eexpr = TVars vl }
- | TNew({cl_kind = KAbstractImpl a} as c,pl,el) ->
- (* a TNew of an abstract implementation is only generated if it is a generic abstract *)
- let at = apply_params a.a_types pl a.a_this in
- let m = mk_mono() in
- let _,cfo =
- try find_to a pl m
- with Not_found ->
- let st = s_type (print_context()) at in
- if has_mono at then
- error ("Type parameters of multi type abstracts must be known (for " ^ st ^ ")") e.epos
- else
- error ("Abstract " ^ (s_type_path a.a_path) ^ " has no @:to function that accepts " ^ st) e.epos;
- in
- begin match cfo with
- | None -> assert false
- | Some cf ->
- let m = follow m in
- let e = make_static_call ctx c cf a pl ((mk (TConst TNull) at e.epos) :: el) m e.epos in
- {e with etype = m}
- end
- | TNew(c,pl,el) ->
- begin try
- let t,_ = (!get_constructor_ref) ctx c pl e.epos in
- begin match follow t with
- | TFun(args,_) ->
- { e with eexpr = TNew(c,pl,call_args ctx el args)}
- | _ ->
- Type.map_expr (loop ctx) e
- end
- with Error _ ->
- (* TODO: when does this happen? *)
- Type.map_expr (loop ctx) e
- end
- | TCall(e1, el) ->
- let e1 = loop ctx e1 in
- begin try
- begin match e1.eexpr with
- | TField(_,FStatic(_,cf)) when Meta.has Meta.To cf.cf_meta ->
- (* do not recurse over @:to functions to avoid infinite recursion *)
- { e with eexpr = TCall(e1,el)}
- | TField(e2,fa) ->
- begin match follow e2.etype with
- | TAbstract(a,pl) when Meta.has Meta.MultiType a.a_meta ->
- let m = get_underlying_type a pl in
- let fname = field_name fa in
- let el = List.map (loop ctx) el in
- begin try
- let ef = mk (TField({e2 with etype = m},quick_field m fname)) e1.etype e2.epos in
- make_call ctx ef el e.etype e.epos
- with Not_found ->
- (* quick_field raises Not_found if m is an abstract, we have to replicate the 'using' call here *)
- match follow m with
- | TAbstract({a_impl = Some c} as a,pl) ->
- let cf = PMap.find fname c.cl_statics in
- make_static_call ctx c cf a pl (e2 :: el) e.etype e.epos
- | _ -> raise Not_found
- end
- | _ -> raise Not_found
- end
- | _ ->
- raise Not_found
- end
+ let cast_or_unify ctx tleft eright p =
+ try
+ cast_or_unify_raise ctx tleft eright p
+ with Error (Unify _ as err,_) ->
+ if not ctx.untyped then display_error ctx (error_msg err) p;
+ eright
+
+ let find_array_access_raise ctx a pl e1 e2o p =
+ let is_set = e2o <> None in
+ let ta = apply_params a.a_params pl a.a_this in
+ let rec loop cfl = match cfl with
+ | [] -> raise Not_found
+ | cf :: cfl when not (Ast.Meta.has Ast.Meta.ArrayAccess cf.cf_meta) ->
+ loop cfl
+ | cf :: cfl ->
+ let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
+ let map t = apply_params a.a_params pl (apply_params cf.cf_params monos t) in
+ let check_constraints () =
+ List.iter2 (fun m (name,t) -> match follow t with
+ | TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
+ List.iter (fun tc -> match follow m with TMono _ -> raise (Unify_error []) | _ -> Type.unify m (map tc) ) constr
+ | _ -> ()
+ ) monos cf.cf_params;
+ in
+ match follow (map cf.cf_type) with
+ | TFun([(_,_,tab);(_,_,ta1);(_,_,ta2)],r) as tf when is_set ->
+ begin try
+ Type.unify tab ta;
+ let e1 = cast_or_unify_raise ctx ta1 e1 p in
+ let e2o = match e2o with None -> None | Some e2 -> Some (cast_or_unify_raise ctx ta2 e2 p) in
+ check_constraints();
+ cf,tf,r,e1,e2o
+ with Unify_error _ | Error (Unify _,_) ->
+ loop cfl
+ end
+ | TFun([(_,_,tab);(_,_,ta1)],r) as tf when not is_set ->
+ begin try
+ Type.unify tab ta;
+ let e1 = cast_or_unify_raise ctx ta1 e1 p in
+ check_constraints();
+ cf,tf,r,e1,None
+ with Unify_error _ | Error (Unify _,_) ->
+ loop cfl
+ end
+ | _ -> loop cfl
+ in
+ loop a.a_array
+
+ let find_array_access ctx a tl e1 e2o p =
+ try find_array_access_raise ctx a tl e1 e2o p
+ with Not_found -> match e2o with
+ | None ->
+ error (Printf.sprintf "No @:arrayAccess function accepts argument of %s" (s_type (print_context()) e1.etype)) p
+ | Some e2 ->
+ error (Printf.sprintf "No @:arrayAccess function accepts arguments of %s and %s" (s_type (print_context()) e1.etype) (s_type (print_context()) e2.etype)) p
+
+ let find_multitype_specialization com a pl p =
+ let m = mk_mono() in
+ let tl = match Meta.get Meta.MultiType a.a_meta with
+ | _,[],_ -> pl
+ | _,el,_ ->
+ let relevant = Hashtbl.create 0 in
+ List.iter (fun e -> match fst e with
+ | EConst(Ident s) -> Hashtbl.replace relevant s true
+ | _ -> error "Type parameter expected" (pos e)
+ ) el;
+ let tl = List.map2 (fun (n,_) t -> if Hashtbl.mem relevant n || not (has_mono t) then t else t_dynamic) a.a_params pl in
+ if com.platform = Js && a.a_path = ([],"Map") then begin match tl with
+ | t1 :: _ ->
+ let rec loop stack t =
+ if List.exists (fun t2 -> fast_eq t t2) stack then
+ t
+ else begin
+ let stack = t :: stack in
+ match follow t with
+ | TAbstract ({ a_path = [],"Class" },_) ->
+ error (Printf.sprintf "Cannot use %s as key type to Map because Class::error::
+ +Perhaps what you are looking for is still on the legacy haxelib site
+
+ This website is listing all the libraries available through the haxelib Haxe package manager.
+ Please visit the haxelib page on Haxe website to learn more about haxelib.
+
+ Here's the list of projects using this tag : +
+ +
+ This website is listing all the libraries available through the haxelib haXe package manager.
+ Please visit the haxelib page on haXe website to learn more about haxelib.
+
+ Here's the list of projects using this tag : +
+ ++ No content for this action +
+ +::end:: + +