diff --git a/Makefile b/Makefile index a97e1d1c9a8..e241d8ff937 100644 --- a/Makefile +++ b/Makefile @@ -27,9 +27,9 @@ STATICLINK?=0 # Configuration -HAXE_DIRECTORIES=compiler context generators generators/gencommon macro filters optimization syntax typing display +HAXE_DIRECTORIES=compiler context generators generators/gencommon macro filters macro/eval optimization syntax typing display EXTLIB_LIBS=extlib-leftovers extc neko javalib swflib ttflib ilib objsize pcre ziplib -FINDLIB_LIBS=unix str threads sedlex xml-light extlib rope ptmap +FINDLIB_LIBS=unix str threads sedlex xml-light extlib rope ptmap dynlink # Includes, packages and compiler @@ -141,6 +141,13 @@ build_pass_3: build_pass_4: $(MODULES:%=%.$(MODULE_EXT)) $(COMPILER) -safe-string -linkpkg -o $(OUTPUT) $(NATIVE_LIBS) $(NATIVE_LIB_FLAG) $(LFLAGS) $(FINDLIB_PACKAGES) $(EXTLIB_INCLUDES) $(EXTLIB_LIBS:=.$(LIB_EXT)) $(MODULES:%=%.$(MODULE_EXT)) +plugin: +ifeq ($(BYTECODE),1) + $(CC_CMD) $(PLUGIN).ml +else + $(COMPILER) $(ALL_CFLAGS) -shared -o $(PLUGIN).cmxs $(PLUGIN).ml +endif + # Only use if you have only changed gencpp.ml quickcpp: _build/src/generators/gencpp.ml build_pass_4 copy_haxetoolkit _build/src/generators/gencpp.ml:src/generators/gencpp.ml diff --git a/src/context/common.ml b/src/context/common.ml index c0f50659dce..214a325fb28 100644 --- a/src/context/common.ml +++ b/src/context/common.ml @@ -474,6 +474,9 @@ module Define = struct | DumpIgnoreVarIds | DynamicInterfaceClosures | EraseGenerics + | EvalDebugger + | EvalStack + | EvalTimes | FastCast | Fdb | FileExtension @@ -571,6 +574,9 @@ module Define = struct | DumpIgnoreVarIds -> ("dump_ignore_var_ids","Remove variable IDs from non-pretty dumps (helps with diff)") | DynamicInterfaceClosures -> ("dynamic_interface_closures","Use slow path for interface closures to save space") | EraseGenerics -> ("erase_generics","Erase generic classes on C#") + | EvalDebugger -> ("eval_debugger","Support debugger in macro/interp mode. Allows host:port value to open a socket. Implies eval_stack.") + | EvalStack -> ("eval_stack","Record stack information in macro/interp mode") + | EvalTimes -> ("eval_times","Record per-method execution times in macro/interp mode. Implies eval_stack.") | FastCast -> ("fast_cast","Enables an experimental casts cleanup on C# and Java") | Fdb -> ("fdb","Enable full flash debug infos for FDB interactive debugging") | FileExtension -> ("file_extension","Output filename extension for cpp source code") diff --git a/src/macro/eval/evalArray.ml b/src/macro/eval/evalArray.ml new file mode 100644 index 00000000000..6c137fdee41 --- /dev/null +++ b/src/macro/eval/evalArray.ml @@ -0,0 +1,188 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open EvalValue + +let create values = { + avalues = values; + alength = Array.length values; +} + +let array_join a f sep = + let buf = Rope.Buffer.create 0 in + let last = Array.length a - 1 in + Array.iteri (fun i v -> + Rope.Buffer.add_rope buf (f v); + if i <> last then Rope.Buffer.add_rope buf sep; + ) a; + Rope.Buffer.contents buf + +let to_list a = Array.to_list (Array.sub a.avalues 0 a.alength) + +let set_length a l = + a.alength <- l; + if a.alength > Array.length a.avalues then begin + let values' = Array.make (a.alength * 2) vnull in + Array.blit a.avalues 0 values' 0 (Array.length a.avalues); + a.avalues <- values' + end + +let unsafe_get a i = a.avalues.(i) +let unsafe_set a i v = a.avalues.(i) <- v + +let concat a a2 = + let values' = Array.make (a.alength + a2.alength) vnull in + Array.blit a.avalues 0 values' 0 a.alength; + let values2 = (Obj.magic a2.avalues) in + Array.blit values2 0 values' a.alength a2.alength; + create values' + +let copy a = + create (Array.sub a.avalues 0 a.alength) + +let filter a f = + create (ExtArray.Array.filter f (Array.sub a.avalues 0 a.alength)) + +let get a i = + if i < 0 || i >= a.alength then vnull + else Array.unsafe_get a.avalues i + +let rec indexOf a equals x fromIndex = + if fromIndex >= a.alength then -1 + else if equals x (Array.get a.avalues fromIndex) then fromIndex + else indexOf a equals x (fromIndex + 1) + +let insert a pos x = + if a.alength + 1 >= Array.length a.avalues then begin + let values' = Array.make (Array.length a.avalues * 2 + 5) vnull in + Array.blit a.avalues 0 values' 0 a.alength; + a.avalues <- values' + end; + Array.blit a.avalues pos a.avalues (pos + 1) (a.alength - pos); + Array.set a.avalues pos x; + a.alength <- a.alength + 1 + +let iterator a = + let i = ref 0 in + let length = a.alength in + (fun () -> + !i < length + ), + (fun () -> + let v = get a !i in + incr i; + v + ) + +let join a f sep = + array_join (Array.sub a.avalues 0 a.alength) f sep + +let lastIndexOf a equals x fromIndex = + let rec loop i = + if i < 0 then -1 + else if equals x (Array.get a.avalues i) then i + else loop (i - 1) + in + if a.alength = 0 then -1 else loop fromIndex + +let map a f = + create (Array.map f (Array.sub a.avalues 0 a.alength)) + +let pop a = + if a.alength = 0 then + vnull + else begin + let v = get a (a.alength - 1) in + a.alength <- a.alength - 1; + v + end + +let push a v = + if a.alength + 1 >= Array.length a.avalues then begin + let values' = Array.make (Array.length a.avalues * 2 + 5) vnull in + Array.blit a.avalues 0 values' 0 a.alength; + Array.set values' a.alength v; + a.avalues <- values' + end else begin + Array.set a.avalues a.alength v; + end; + a.alength <- a.alength + 1; + a.alength + +let remove a equals x = + let i = indexOf a equals x 0 in + if i < 0 then + false + else begin + Array.blit a.avalues (i + 1) a.avalues i (a.alength - i - 1); + a.alength <- a.alength - 1; + true + end + +let reverse a = + a.avalues <- ExtArray.Array.rev (Array.sub a.avalues 0 a.alength) + +let set a i v = + if i >= a.alength then begin + if i >= Array.length a.avalues then begin + let values' = Array.make (i + 5) vnull in + Array.blit a.avalues 0 values' 0 a.alength; + a.avalues <- values'; + end; + a.alength <- i + 1; + end; + Array.unsafe_set a.avalues i v + +let shift a = + if a.alength = 0 then + vnull + else begin + let v = get a 0 in + a.alength <- a.alength - 1; + Array.blit a.avalues 1 a.avalues 0 a.alength; + v + end + +let slice a pos end' = + if pos > a.alength || pos >= end' then + create [||] + else + create (Array.sub a.avalues pos (end' - pos)) + +let sort a f = + a.avalues <- Array.sub a.avalues 0 a.alength; + Array.sort f a.avalues + +let splice a pos len end' = + let values' = Array.init len (fun i -> Array.get a.avalues (pos + i)) in + Array.blit a.avalues (pos + len) a.avalues pos (a.alength - end'); + a.alength <- a.alength - len; + create values' + +let unshift a v = + if a.alength + 1 >= Array.length a.avalues then begin + let values' = Array.make (Array.length a.avalues * 2 + 5) vnull in + Array.blit a.avalues 0 values' 1 a.alength; + a.avalues <- values' + end else begin + Array.blit a.avalues 0 a.avalues 1 a.alength; + end; + Array.set a.avalues 0 v; + a.alength <- a.alength + 1 \ No newline at end of file diff --git a/src/macro/eval/evalContext.ml b/src/macro/eval/evalContext.ml new file mode 100644 index 00000000000..ade171d9069 --- /dev/null +++ b/src/macro/eval/evalContext.ml @@ -0,0 +1,363 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open Type +open EvalValue +open EvalHash + +type var_info = string + +type scope = { + pos : pos; + (* The local start offset of the current scope. *) + local_offset : int; + (* The locals declared in the current scope. Maps variable IDs to local slots. *) + mutable locals : (int,int) Hashtbl.t; + (* The name of local variables. Maps local slots to variable names. Only filled in debug mode. *) + mutable local_infos : (int,var_info) Hashtbl.t; + (* The IDs of local variables. Maps variable names to variable IDs. *) + mutable local_ids : (string,int) Hashtbl.t; +} + +type env_kind = + | EKLocalFunction of int + | EKMethod of int * int + | EKDelayed + +type env_info = { + static : bool; + pfile : int; + kind : env_kind; + capture_infos : (int,var_info) Hashtbl.t; +} + +type env_debug = { + timer : unit -> unit; + mutable scopes : scope list; + mutable line : int; + mutable expr : texpr; +} + +type env = { + env_info : env_info; + env_debug : env_debug; + mutable env_leave_pmin : int; + mutable env_leave_pmax : int; + mutable env_in_use : bool; + env_locals : value array; + env_captures : value ref array; +} + +type breakpoint_state = + | BPEnabled + | BPDisabled + | BPHit + +type breakpoint_column = + | BPAny + | BPColumn of int + +type breakpoint = { + bpid : int; + bpfile : int; + bpline : int; + bpcolumn : breakpoint_column; + mutable bpstate : breakpoint_state; +} + +type debug_state = + | DbgStart + | DbgRunning + | DbgWaiting + | DbgContinue + | DbgNext of int + | DbgFinish of int + +type builtins = { + mutable instance_builtins : (int * value) list IntMap.t; + mutable static_builtins : (int * value) list IntMap.t; + constructor_builtins : (int,value list -> value) Hashtbl.t; + empty_constructor_builtins : (int,unit -> value) Hashtbl.t; +} + +type debug_socket = { + addr : Unix.inet_addr; + port : int; + mutable socket : Unix.file_descr option; +} + +type debug = { + debug : bool; + breakpoints : (int,(int,breakpoint) Hashtbl.t) Hashtbl.t; + mutable support_debugger : bool; + mutable debug_state : debug_state; + mutable breakpoint : breakpoint; + caught_types : (int,bool) Hashtbl.t; + mutable environment_offset_delta : int; + mutable debug_socket : debug_socket option; +} + +type eval = { + environments : env DynArray.t; + mutable environment_offset : int; +} + +type context = { + ctx_id : int; + is_macro : bool; + record_stack : bool; + detail_times : bool; + builtins : builtins; + debug : debug; + mutable had_error : bool; + mutable curapi : value MacroApi.compiler_api; + mutable type_cache : Type.module_type IntMap.t; + overrides : (Type.path * string,bool) Hashtbl.t; + (* prototypes *) + mutable string_prototype : vprototype; + mutable instance_prototypes : vprototype IntMap.t; + mutable static_prototypes : vprototype IntMap.t; + mutable constructors : value Lazy.t IntMap.t; + get_object_prototype : 'a . context -> (int * 'a) list -> vprototype * (int * 'a) list; + (* eval *) + eval : eval; + mutable exception_stack : (pos * env_kind) list; +} + +let get_ctx_ref : (unit -> context) ref = ref (fun() -> assert false) +let get_ctx () = (!get_ctx_ref)() +let select ctx = get_ctx_ref := (fun() -> ctx) + +(* Misc *) + +let get_eval ctx = + ctx.eval + +let rec kind_name ctx kind = + let rec loop kind env_id = match kind, env_id with + | EKLocalFunction i, 0 -> + Printf.sprintf "localFunction%i" i + | EKLocalFunction i, env_id -> + let parent_id = env_id - 1 in + let env = DynArray.get ctx.environments parent_id in + Printf.sprintf "%s.localFunction%i" (loop env.env_info.kind parent_id) i + | EKMethod(i1,i2),_ -> Printf.sprintf "%s.%s" (rev_hash_s i1) (rev_hash_s i2) + | EKDelayed,_ -> "delayed" + in + loop kind ctx.environment_offset + +let vstring s = + VString (s,lazy (Rope.to_string s)) + +let vstring_direct (r,s) = + VString(r,s) + +let call_function f vl = match f,vl with + | Fun0 f,_ -> f() + | Fun1 f,[] -> f vnull + | Fun1 f,(a :: _) -> f a + | Fun2 f,[] -> f vnull vnull + | Fun2 f,[a] -> f a vnull + | Fun2 f,(a :: b :: _) -> f a b + | Fun3 f,[] -> f vnull vnull vnull + | Fun3 f,[a] -> f a vnull vnull + | Fun3 f,[a;b] -> f a b vnull + | Fun3 f,(a :: b :: c :: _) -> f a b c + | Fun4 f,[] -> f vnull vnull vnull vnull + | Fun4 f,[a] -> f a vnull vnull vnull + | Fun4 f,[a;b] -> f a b vnull vnull + | Fun4 f,[a;b;c] -> f a b c vnull + | Fun4 f,(a :: b :: c :: d :: _) -> f a b c d + | Fun5 f,[] -> f vnull vnull vnull vnull vnull + | Fun5 f,[a] -> f a vnull vnull vnull vnull + | Fun5 f,[a;b] -> f a b vnull vnull vnull + | Fun5 f,[a;b;c] -> f a b c vnull vnull + | Fun5 f,[a;b;c;d] -> f a b c d vnull + | Fun5 f,(a :: b :: c :: d :: e :: _) -> f a b c d e + | FunN f,_ -> f vl + +let object_fields o = + let fields = IntMap.fold (fun key vvalue acc -> (key,vvalue) :: acc) o.oextra [] in + IntMap.fold (fun key index acc -> + if IntMap.mem key o.oremoved then acc + else (key,(o.ofields.(index))) :: acc + ) o.oproto.pinstance_names fields + +let instance_fields i = + IntMap.fold (fun name key acc -> + (name,i.ifields.(key)) :: acc + ) i.iproto.pinstance_names [] + +let proto_fields proto = + IntMap.fold (fun name key acc -> + (name,proto.pfields.(key)) :: acc + ) proto.pnames [] + +(* Exceptions *) + +exception RunTimeException of value * env list * pos + +let call_stack ctx = + if not ctx.record_stack then + [] + else + List.rev (DynArray.to_list (DynArray.sub ctx.eval.environments 0 ctx.eval.environment_offset)) + +let throw v p = + let ctx = get_ctx() in + let eval = get_eval ctx in + if ctx.record_stack && eval.environment_offset > 0 then begin + let env = DynArray.get eval.environments (eval.environment_offset - 1) in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + end; + raise (RunTimeException(v,call_stack ctx,p)) + +let exc v = throw v null_pos + +let exc_string str = exc (vstring (Rope.of_string str)) + +(* Environment handling *) + +let no_timer = fun () -> () +let empty_array = [||] +let no_expr = mk (TConst TNull) t_dynamic null_pos + +let no_debug = { + timer = no_timer; + scopes = []; + line = 0; + expr = no_expr +} + +let create_env_info static pfile kind capture_infos = + let info = { + static = static; + kind = kind; + pfile = pfile; + capture_infos = capture_infos; + } in + info + +let push_environment_debug ctx info num_locals num_captures = + let eval = get_eval ctx in + let timer = if ctx.detail_times then + Common.timer ["macro";"execution";kind_name eval info.kind] + else + no_timer + in + let env = { + env_info = info; + env_leave_pmin = 0; + env_leave_pmax = 0; + env_in_use = false; + env_debug = { + timer = timer; + scopes = []; + line = 0; + expr = no_expr; + }; + env_locals = Array.make num_locals vnull; + env_captures = Array.make num_captures (ref vnull); + } in + if eval.environment_offset = DynArray.length eval.environments then + DynArray.add eval.environments env + else + DynArray.unsafe_set eval.environments eval.environment_offset env; + eval.environment_offset <- eval.environment_offset + 1; + env + +let create_default_environment ctx info num_locals = + { + env_info = info; + env_leave_pmin = 0; + env_leave_pmax = 0; + env_in_use = false; + env_debug = no_debug; + env_locals = Array.make num_locals vnull; + env_captures = empty_array; + } + +let pop_environment_debug ctx env = + let eval = get_eval ctx in + eval.environment_offset <- eval.environment_offset - 1; + env.env_debug.timer(); + () + +let push_environment ctx info num_locals num_captures = + if ctx.record_stack then + push_environment_debug ctx info num_locals num_captures + else { + env_info = info; + env_leave_pmin = 0; + env_leave_pmax = 0; + env_in_use = false; + env_debug = no_debug; + env_locals = Array.make num_locals vnull; + env_captures = Array.make num_captures (ref vnull); + } +[@@inline] + +let pop_environment ctx env = + if ctx.record_stack then pop_environment_debug ctx env else () +[@@inline] + +(* Prototypes *) + +let get_static_prototype_raise ctx path = + IntMap.find path ctx.static_prototypes + +let get_static_prototype ctx path p = + try get_static_prototype_raise ctx path + with Not_found -> Error.error (Printf.sprintf "[%i] Type not found: %s" ctx.ctx_id (rev_hash_s path)) p + +let get_static_prototype_as_value ctx path p = + (get_static_prototype ctx path p).pvalue + +let get_instance_prototype_raise ctx path = + IntMap.find path ctx.instance_prototypes + +let get_instance_prototype ctx path p = + try get_instance_prototype_raise ctx path + with Not_found -> Error.error (Printf.sprintf "[%i] Instance prototype not found: %s" ctx.ctx_id (rev_hash_s path)) p + +let get_instance_constructor_raise ctx path = + IntMap.find path ctx.constructors + +let get_instance_constructor ctx path p = + try get_instance_constructor_raise ctx path + with Not_found -> Error.error (Printf.sprintf "[%i] Instance constructor not found: %s" ctx.ctx_id (rev_hash_s path)) p + +let get_special_instance_constructor_raise ctx path = + Hashtbl.find (get_ctx()).builtins.constructor_builtins path + +let get_proto_field_index_raise proto name = + IntMap.find name proto.pnames + +let get_proto_field_index proto name = + try get_proto_field_index_raise proto name + with Not_found -> Error.error (Printf.sprintf "Field index for %s not found on prototype %s" (rev_hash_s name) (rev_hash_s proto.ppath)) null_pos + +let get_instance_field_index_raise proto name = + IntMap.find name proto.pinstance_names + +let get_instance_field_index proto name = + try get_instance_field_index_raise proto name + with Not_found -> Error.error (Printf.sprintf "Field index for %s not found on prototype %s" (rev_hash_s name) (rev_hash_s proto.ppath)) null_pos diff --git a/src/macro/eval/evalDebug.ml b/src/macro/eval/evalDebug.ml new file mode 100644 index 00000000000..f25f55bf5f3 --- /dev/null +++ b/src/macro/eval/evalDebug.ml @@ -0,0 +1,99 @@ +open Gc +open Globals +open Ast +open Type +open EvalJitContext +open EvalContext +open EvalValue +open EvalExceptions +open EvalPrinting +open EvalHash +open EvalEncode +open EvalMisc +open EvalDebugMisc +open MacroApi + +let is_caught ctx v = + try + Hashtbl.iter (fun path _ -> if is v path then raise Exit) ctx.debug.caught_types; + false + with Exit -> + true + +(* Checks debug state and calls what's needed. *) +let rec run_loop ctx wait run env : value = + let check_breakpoint () = + if ctx.debug.breakpoint.bpstate = BPHit && env.env_debug.line <> ctx.debug.breakpoint.bpline then ctx.debug.breakpoint.bpstate <- BPEnabled + in + match ctx.debug.debug_state with + | DbgRunning -> + check_breakpoint(); + run env + | DbgContinue -> + check_breakpoint(); + run env + | DbgNext offset -> + if offset < (get_eval ctx).environment_offset then + run env + else begin + ctx.debug.debug_state <- DbgWaiting; + run_loop ctx wait run env + end + | DbgFinish offset -> + if offset <= (get_eval ctx).environment_offset then + run env + else begin + ctx.debug.debug_state <- DbgWaiting; + run_loop ctx wait run env + end + | DbgWaiting | DbgStart -> + wait ctx run env + +let debug_loop jit e f = + let ctx = jit.ctx in + let scopes = jit.scopes in + let line,col1,_,_ = Lexer.get_pos_coords e.epos in + let column_matches breakpoint = match breakpoint.bpcolumn with + | BPAny -> true + | BPColumn i -> i = col1 + 1 + in + let conn = match ctx.debug.debug_socket with + | Some socket -> EvalDebugSocket.make_connection socket + | None -> EvalDebugCLI.connection + in + (* Checks if we hit a breakpoint, runs the code if not. *) + let rec run_check_breakpoint env = + try + let h = Hashtbl.find ctx.debug.breakpoints env.env_info.pfile in + let breakpoint = Hashtbl.find h env.env_debug.line in + begin match breakpoint.bpstate with + | BPEnabled when column_matches breakpoint -> + breakpoint.bpstate <- BPHit; + ctx.debug.breakpoint <- breakpoint; + conn.bp_stop ctx env; + ctx.debug.debug_state <- DbgWaiting; + run_loop ctx conn.wait run_check_breakpoint env + | _ -> + raise Not_found + end + with Not_found -> try + f env + with + | RunTimeException(v,_,_) when not (is_caught ctx v) -> + conn.exc_stop ctx v e.epos; + ctx.debug.debug_state <- DbgWaiting; + run_loop ctx conn.wait run_check_breakpoint env + | BreakHere -> + conn.bp_stop ctx env; + ctx.debug.debug_state <- DbgWaiting; + run_loop ctx conn.wait run_check_breakpoint env + + in + (* Sets the environmental debug data, then executes the debug loop. *) + let run_set env = + env.env_debug.scopes <- scopes; + env.env_debug.line <- line; + env.env_debug.expr <- e; + run_loop ctx conn.wait run_check_breakpoint env; + in + run_set \ No newline at end of file diff --git a/src/macro/eval/evalDebugCLI.ml b/src/macro/eval/evalDebugCLI.ml new file mode 100644 index 00000000000..8d193967279 --- /dev/null +++ b/src/macro/eval/evalDebugCLI.ml @@ -0,0 +1,389 @@ +open Gc +open Ast +open Type +open Globals +open MacroApi +open EvalContext +open EvalValue +open EvalExceptions +open EvalHash +open EvalPrinting +open EvalMisc +open EvalDebugMisc + +let get_call_stack_envs ctx kind p = + let envs = match call_stack ctx with + | _ :: envs -> envs + | [] -> [] + in + let rec loop delta envs = match envs with + | _ :: envs when delta < 0 -> loop (delta + 1) envs + | _ -> envs + in + loop ctx.debug.environment_offset_delta envs + +(* Printing *) + +let value_string value = + let rec fields_string depth fields = + let tabs = String.make (depth * 2) ' ' in + let l = List.map (fun (name,value) -> + let s_type,s_value = value_string depth value in + Printf.sprintf "%s%s : %s = %s" tabs (rev_hash_s name) s_type s_value + ) fields in + Printf.sprintf "{\n%s\n%s}" (String.concat "\n" l) tabs + and instance_fields depth vi = + let fields = IntMap.fold (fun name key acc -> + (name,vi.ifields.(key)) :: acc + ) vi.iproto.pinstance_names [] in + fields_string (depth + 1) fields + and value_string depth v = match v with + | VNull -> "NULL","null" + | VTrue -> "Bool","true" + | VFalse -> "Bool","false" + | VInt32 i -> "Int",Int32.to_string i + | VFloat f -> "Float",string_of_float f + | VEnumValue ev -> rev_hash_s ev.epath,Rope.to_string (s_enum_value 0 ev) + | VObject o -> "Anonymous",fields_string (depth + 1) (object_fields o) + | VString(_,s) -> "String","\"" ^ (Ast.s_escape (Lazy.force s)) ^ "\"" + | VArray va -> "Array",Rope.to_string (s_array (depth + 1) va) + | VVector vv -> "Vector",Rope.to_string (s_vector (depth + 1) vv) + | VInstance vi -> rev_hash_s vi.iproto.ppath,instance_fields (depth + 1) vi + | VPrototype proto -> "Anonymous",Rope.to_string (s_proto_kind proto) + | VFunction _ | VFieldClosure _ -> "Function","fun" + in + let s_type,s_value = value_string 0 value in + Printf.sprintf "%s = %s" s_type s_value + +let send_string s = + print_endline s + +let output_info = send_string +let output_error = send_string + +let output_exception_stop ctx v pos = + output_info (uncaught_exception_string v pos "") + +let output_variable_name name = + send_string (Printf.sprintf "%s" name) + +let output_value name value = + send_string (Printf.sprintf "%s : %s" name (value_string value)) + +let output_call_stack_position ctx i kind p = + let line = Lexer.get_error_line p in + send_string (Printf.sprintf "%6i : %s at %s:%i" i (kind_name (get_eval ctx) kind) (Path.get_real_path p.pfile) line) + +let output_call_stack ctx kind p = + let envs = get_call_stack_envs ctx kind p in + let i = ref ((get_eval ctx).environment_offset - 1) in + output_call_stack_position ctx !i kind {p with pfile = Path.unique_full_path p.Globals.pfile}; + List.iter (fun env -> + if env.env_leave_pmin >= 0 then begin + let p = {pmin = env.env_leave_pmin; pmax = env.env_leave_pmax; pfile = rev_file_hash env.env_info.pfile} in + decr i; + output_call_stack_position ctx !i env.env_info.kind p + end + ) envs + +let output_file_path s = send_string (Path.get_real_path s) + +let output_type_name = send_string +let output_breakpoint breakpoint = + let flag = match breakpoint.bpstate with + | BPHit | BPEnabled -> "E" + | BPDisabled -> "d" + in + send_string (Printf.sprintf "%i %s" breakpoint.bpid flag) + +let output_breakpoints ctx = + iter_breakpoints ctx (fun breakpoint -> + output_breakpoint breakpoint + ) + +let output_breakpoint_set breakpoint = + output_info (Printf.sprintf "Breakpoint %i set and enabled" breakpoint.bpid) + +let output_breakpoint_stop ctx env = + output_info (Printf.sprintf "Thread %i stopped in %s at %s:%i." 0 (kind_name (get_eval ctx) env.env_info.kind) (rev_file_hash env.env_info.pfile) env.env_debug.line) + +let output_breakpoint_description breakpoint = + let s_col = match breakpoint.bpcolumn with + | BPAny -> "" + | BPColumn i -> ":" ^ (string_of_int i) + in + send_string (Printf.sprintf "%s:%i%s" ((Path.get_real_path (rev_file_hash breakpoint.bpfile))) breakpoint.bpline s_col) + +let read_line () = + input_line Pervasives.stdin + +let parse_breakpoint_pattern pattern = + (* TODO: more than file:line patterns? *) + try + let split = ExtString.String.nsplit pattern ":" in + let file,line,column = match List.rev split with + | first :: rest -> + let first = int_of_string first in + begin match rest with + | second :: file -> + begin try + file,(int_of_string second),BPColumn first + with _ -> + (second :: file),first,BPAny + end + | file -> + file,first,BPAny + end + | [] -> raise Exit + in + let file = String.concat ":" (List.rev file) in + file,line,column + with _ -> + raise Exit + +let print_variables ctx capture_infos scopes env = + let rec loop scopes = match scopes with + | scope :: scopes -> + Hashtbl.iter (fun _ name -> output_variable_name name) scope.local_infos; + loop scopes + | [] -> + () + in + loop scopes; + Hashtbl.iter (fun slot name -> + if slot < Array.length env.env_captures then + output_variable_name name + ) capture_infos + + +let set_variable ctx scopes name value env = + try + let slot = get_var_slot_by_name scopes name in + env.env_locals.(slot) <- value; + output_value name value; + with Not_found -> + output_error ("No variable found: " ^ name) + +(* Reads input and reacts accordingly. *) +let rec wait ctx run env = + let get_real_env ctx = + ctx.debug.environment_offset_delta <- 0; + DynArray.get (get_eval ctx).environments ((get_eval ctx).environment_offset - 1); + in + let rec move_frame offset : value = + if offset < 0 || offset >= (get_eval ctx).environment_offset then begin + output_error (Printf.sprintf "Frame out of bounds: %i (valid range is %i - %i)" offset 0 ((get_eval ctx).environment_offset - 1)); + loop() + end else begin + ctx.debug.environment_offset_delta <- ((get_eval ctx).environment_offset - offset - 1); + wait ctx run (DynArray.get (get_eval ctx).environments offset); + end + and loop () = + print_string "1> "; + flush stdout; + let line = read_line () in + match ExtString.String.nsplit line " " with + | ["quit" | "exit"] -> + (* TODO: Borrowed from interp.ml *) + if (get_ctx()).curapi.use_cache() then raise (Error.Fatal_error ("",Globals.null_pos)); + raise (Interp.Sys_exit 0); + | ["detach"] -> + Hashtbl.iter (fun _ h -> + Hashtbl.clear h + ) ctx.debug.breakpoints; + ctx.debug.debug_state <- DbgRunning; + run env + (* source | history *) + | ["files" | "filespath"] -> + Hashtbl.iter (fun i _ -> + output_file_path (rev_file_hash i); + ) ctx.debug.breakpoints; + loop() + | ["classes"] -> + IntMap.iter (fun i _ -> + output_type_name (rev_hash_s i) + ) ctx.type_cache; + loop() + | ["mem"] -> + output_info (Printf.sprintf "%i" (Gc.stat()).live_words); + loop() + | ["compact"] -> + let before = (Gc.stat()).live_words in + Gc.compact(); + let after = (Gc.stat()).live_words in + output_info (Printf.sprintf "before: %i\nafter: %i" before after); + loop() + | ["collect"] -> + let before = (Gc.stat()).live_words in + Gc.full_major(); + let after = (Gc.stat()).live_words in + output_info (Printf.sprintf "before: %i\nafter: %i" before after); + loop() + | ["break" | "b";pattern] -> + begin try + let file,line,column = parse_breakpoint_pattern pattern in + begin try + let breakpoint = add_breakpoint ctx file line column in + output_breakpoint_set breakpoint; + with Not_found -> + output_error ("Could not find file " ^ file); + end; + with Exit -> + output_error "Unrecognized breakpoint pattern"; + end; + loop() + | ["list" | "l"] -> + (* TODO: other list syntax *) + output_breakpoints ctx; + loop() + | ["describe" | "desc";bpid] -> + (* TODO: range patterns? *) + begin try + let breakpoint = find_breakpoint ctx bpid in + output_breakpoint_description breakpoint; + with Not_found -> + output_error (Printf.sprintf "Unknown breakpoint: %s" bpid); + end; + loop() + | ["disable" | "dis";bpid] -> + (* TODO: range patterns? *) + if bpid = "all" then + iter_breakpoints ctx (fun breakpoint -> breakpoint.bpstate <- BPDisabled) + else begin try + let breakpoint = find_breakpoint ctx bpid in + breakpoint.bpstate <- BPDisabled; + output_info (Printf.sprintf "Breakpoint %s disabled" bpid); + with Not_found -> + output_error (Printf.sprintf "Unknown breakpoint: %s" bpid); + end; + loop() + | ["enable" | "en";bpid] -> + (* TODO: range patterns? *) + if bpid = "all" then + iter_breakpoints ctx (fun breakpoint -> breakpoint.bpstate <- BPEnabled) + else begin try + let breakpoint = find_breakpoint ctx bpid in + breakpoint.bpstate <- BPEnabled; + output_info (Printf.sprintf "Breakpoint %s enabled" bpid); + with Not_found -> + output_error (Printf.sprintf "Unknown breakpoint: %s" bpid); + end; + loop() + | ["delete" | "d";bpid] -> + (* TODO: range patterns? *) + if bpid = "all" then + Hashtbl.iter (fun _ h -> + Hashtbl.clear h + ) ctx.debug.breakpoints + else begin try + let id = try int_of_string bpid with _ -> raise Not_found in + Hashtbl.iter (fun _ h -> + let to_delete = ref [] in + Hashtbl.iter (fun k breakpoint -> if breakpoint.bpid = id then to_delete := k :: !to_delete) h; + List.iter (fun k -> Hashtbl.remove h k) !to_delete; + ) ctx.debug.breakpoints; + output_info (Printf.sprintf "Breakpoint %s deleted" bpid); + with Not_found -> + output_error (Printf.sprintf "Unknown breakpoint: %s" bpid); + end; + loop() + | ["clear";pattern] -> + (* TODO: range patterns? *) + begin try + let file,line,column = parse_breakpoint_pattern pattern in + begin try + delete_breakpoint ctx file line + with Not_found -> + output_info (Printf.sprintf "Could not find breakpoint %s:%i" file line); + end + with Exit -> + output_error ("Unrecognized breakpoint pattern"); + end; + loop() + (* thread | unsafe | safe *) + | ["continue" | "c"] -> + let env = get_real_env ctx in + ctx.debug.debug_state <- (if ctx.debug.debug_state = DbgStart then DbgRunning else DbgContinue); + run env + | ["step" | "s" | ""] -> + let env = get_real_env ctx in + run env + | ["next" | "n"] -> + let env = get_real_env ctx in + ctx.debug.debug_state <- DbgNext (get_eval ctx).environment_offset; + run env + | ["finish" | "f"] -> + let env = get_real_env ctx in + ctx.debug.debug_state <- DbgFinish (get_eval ctx).environment_offset; + run env + | ["where" | "w"] -> + output_call_stack ctx env.env_info.kind env.env_debug.expr.epos; + loop() + | ["up"] -> + let offset = (get_eval ctx).environment_offset - ctx.debug.environment_offset_delta in + move_frame (offset - 2) + | ["down"] -> + let offset = (get_eval ctx).environment_offset - ctx.debug.environment_offset_delta in + move_frame offset + | ["frame";sframe] -> + let frame = try + Some (int_of_string sframe) + with _ -> + None + in + begin match frame with + | Some frame -> move_frame ((get_eval ctx).environment_offset - frame - 1) + | None -> + output_error ("Invalid frame format: " ^ sframe); + loop() + end + | ["variables" | "vars"] -> + print_variables ctx env.env_info.capture_infos env.env_debug.scopes env; + loop() + | ["print" | "p";e] -> + begin try + let e = parse_expr ctx e env.env_debug.expr.epos in + begin try + let name,v = expr_to_value ctx env e in + output_value name v + with Exit -> + output_error ("Don't know how to handle this expression: " ^ (Ast.s_expr e)) + end + with Parse_expr_error e -> + output_error e + end; + loop() + | ["set" | "s";expr_s;"=";value] -> + let parse s = parse_expr ctx s env.env_debug.expr.epos in + begin try + let expr,value = parse expr_s,parse value in + begin try + let _,value = expr_to_value ctx env value in + begin match fst expr with + (* TODO: support setting array elements and enum values *) + | EField(e1,s) -> + let _,v1 = expr_to_value ctx env e1 in + set_field v1 (hash_s s) value; + | EConst (Ident s) -> + set_variable ctx env.env_debug.scopes s value env; + | _ -> + raise Exit + end + with Exit -> + output_error ("Don't know how to handle this expression") + end + with Parse_expr_error e -> + output_error e + end; + loop() + | s -> + output_error (Printf.sprintf "Unknown command: %s" (String.concat " " s)); + loop() + in + loop () + +let connection : debug_connection = { + wait = wait; + bp_stop = output_breakpoint_stop; + exc_stop = output_exception_stop; +} diff --git a/src/macro/eval/evalDebugMisc.ml b/src/macro/eval/evalDebugMisc.ml new file mode 100644 index 00000000000..970ce852646 --- /dev/null +++ b/src/macro/eval/evalDebugMisc.ml @@ -0,0 +1,185 @@ +open Ast +open Globals +open MacroApi +open EvalContext +open EvalHash +open EvalValue +open EvalEncode + +type debug_connection = { + wait : context -> (env -> value) -> env -> value; + bp_stop : context -> env -> unit; + exc_stop : context -> value -> pos -> unit; +} + +exception BreakHere + +(* Breakpoints *) + +let make_breakpoint = + let id = ref (-1) in + (fun file line state column -> + incr id; + { + bpid = !id; + bpfile = file; + bpline = line; + bpstate = state; + bpcolumn = column; + } + ) + +let iter_breakpoints ctx f = + Hashtbl.iter (fun _ breakpoints -> + Hashtbl.iter (fun _ breakpoint -> f breakpoint) breakpoints + ) ctx.debug.breakpoints + +let add_breakpoint ctx file line column = + let hash = hash_s (Path.unique_full_path (Common.find_file (ctx.curapi.get_com()) file)) in + let h = try + Hashtbl.find ctx.debug.breakpoints hash + with Not_found -> + let h = Hashtbl.create 0 in + Hashtbl.add ctx.debug.breakpoints hash h; + h + in + let breakpoint = make_breakpoint hash line BPEnabled column in + Hashtbl.replace h line breakpoint; + breakpoint + +let delete_breakpoint ctx file line = + let hash = hash_s (Path.unique_full_path (Common.find_file (ctx.curapi.get_com()) file)) in + let h = Hashtbl.find ctx.debug.breakpoints hash in + Hashtbl.remove h line + +let find_breakpoint ctx sid = + let found = ref None in + let id = try int_of_string sid with _ -> raise Not_found in + try + iter_breakpoints ctx (fun breakpoint -> + if breakpoint.bpid = id then begin + found := Some breakpoint; + raise Exit + end + ); + raise Not_found + with Exit -> + match !found with None -> assert false | Some breakpoint -> breakpoint + + +(* Helper *) + +exception Parse_expr_error of string + +let parse_expr ctx s p = + let error s = raise (Parse_expr_error s) in + Parser.parse_expr_string (ctx.curapi.get_com()) s p error false + +(* Vars *) + +let get_var_slot_by_name scopes name = + let rec loop scopes = match scopes with + | scope :: scopes -> + begin try + let id = Hashtbl.find scope.local_ids name in + let slot = Hashtbl.find scope.locals id in + slot + scope.local_offset + with Not_found -> + loop scopes + end + | [] -> + raise Not_found + in + loop scopes + +let get_capture_slot_by_name capture_infos name = + let ret = ref None in + try + Hashtbl.iter (fun slot name' -> + if name = name' then begin + ret := (Some slot); + raise Exit + end + ) capture_infos; + raise Not_found + with Exit -> + match !ret with None -> assert false | Some name -> name + +let get_variable capture_infos scopes name env = + try + let slot = get_var_slot_by_name scopes name in + let value = env.env_locals.(slot) in + value + with Not_found -> + let slot = get_capture_slot_by_name capture_infos name in + let value = try env.env_captures.(slot) with _ -> raise Not_found in + !value + +(* Expr to value *) + +let resolve_ident ctx env s = + let key = hash_s s in + try + (* 1. Variable *) + get_variable env.env_info.capture_infos env.env_debug.scopes s env + with Not_found -> try + (* 2. Instance *) + if env.env_info.static then raise Not_found; + let v = env.env_locals.(0) in + EvalField.field_raise v key + with Not_found -> try + (* 3. Static *) + begin match env.env_info.kind with + | EKMethod(i1,_) -> + let proto = get_static_prototype_raise ctx i1 in + EvalField.proto_field_raise proto key + | _ -> + raise Not_found + end + with Not_found -> try + (* 4. Type *) + VPrototype (IntMap.find key ctx.static_prototypes) + with Not_found -> + raise Exit + +let expr_to_value ctx env e = + let rec loop e = match fst e with + | EConst cst -> + begin match cst with + | String s -> "",encode_string s + | Int s -> "",VInt32 (Int32.of_string s) + | Float s -> "",VFloat (float_of_string s) + | Ident "true" -> "",VTrue + | Ident "false" -> "",VFalse + | Ident "null" -> "",VNull + | Ident s -> + let value = resolve_ident ctx env s in + s,value + | _ -> raise Exit + end + | EArray(e1,eidx) -> + let n1,v1 = loop e1 in + let nidx,vidx = loop eidx in + let idx = match vidx with VInt32 i -> Int32.to_int i | _ -> raise Exit in + let n = Printf.sprintf "%s[%d]" n1 idx in + begin match v1 with + | VArray va -> + let v = EvalArray.get va idx in + (n,v) + | VVector vv -> + let v = Array.get vv idx in + (n,v) + | VEnumValue ev -> + let v = Array.get ev.eargs idx in + (n,v) + | _ -> + raise Exit + end + | EField(e1,s) -> + let n1,v1 = loop e1 in + let v = EvalField.field v1 (hash_s s) in + (Printf.sprintf "%s.%s" n1 s),v + | _ -> + raise Exit + in + loop e diff --git a/src/macro/eval/evalDebugSocket.ml b/src/macro/eval/evalDebugSocket.ml new file mode 100644 index 00000000000..2f9dfba85e0 --- /dev/null +++ b/src/macro/eval/evalDebugSocket.ml @@ -0,0 +1,571 @@ +open Gc +open Ast +open Type +open Globals +open MacroApi +open Unix +open Json +open EvalContext +open EvalValue +open EvalHash +open EvalPrinting +open EvalMisc +open EvalDebugMisc + +module JsonRpc = struct + let jsonrpc_field = "jsonrpc", JString "2.0" + + let notification method_name params = + let fl = [ + jsonrpc_field; + "method", JString method_name; + ] in + let fl = Option.map_default (fun params -> ("params",params) :: fl) fl params in + JObject fl + + let result id data = + JObject [ + jsonrpc_field; + "id", id; + "result", data; + ] + + let error id code message = + JObject [ + jsonrpc_field; + "id", id; + "error", JObject [ + "code", JInt code; + "message", JString message; + ]; + ] + + type json_rpc_error = + | Parse_error of string + | Invalid_request of string + | Method_not_found of Json.t * string (* id->methodname *) + | Invalid_params of Json.t + | Custom of Json.t * int * string (* id->code->message *) + + exception JsonRpc_error of json_rpc_error + + let handle_jsonrpc_error f output = + try f () with JsonRpc_error e -> + match e with + | Parse_error s -> output (error JNull (-32700) s) + | Invalid_request s -> output (error JNull (-32600) s) + | Method_not_found (id,meth) -> output (error id (-32601) (Printf.sprintf "Method `%s` not found" meth)) + | Invalid_params id -> output (error id (-32602) "Invalid params") + | Custom (id,code,msg) -> output (error id code msg) + + let process_request input handle output = + let open Json.Reader in + let lexbuf = Sedlexing.Utf8.from_string input in + let json = try read_json lexbuf with Json_error s -> raise (JsonRpc_error (Parse_error s)) in + let fields = match json with JObject fl -> fl | _ -> raise (JsonRpc_error (Invalid_request "not an object")) in + let get_field name map = + let field = try List.find (fun (n,_) -> n = name) fields with Not_found -> raise (JsonRpc_error (Invalid_request ("no `" ^ name ^ "` field"))) in + let value = map (snd field) in + match value with + | None -> raise (JsonRpc_error (Invalid_request (Printf.sprintf "`%s` field has invalid data" name))) + | Some v -> v + in + let id = get_field "id" (fun v -> Some v) in + let meth = get_field "method" (function JString s -> Some s | _ -> None) in + let params = + try + let f = List.find (fun (n,_) -> n = "params") fields in + Some (snd f) + with Not_found -> + None + in + let res = handle id meth params in + output id res +end + +module Transport = struct + let read_byte this i = int_of_char (Bytes.get this i) + + let read_ui16 this i = + let ch1 = read_byte this i in + let ch2 = read_byte this (i + 1) in + ch1 lor (ch2 lsl 8) + + let read_string socket = + match socket.socket with + | None -> + failwith "no socket" (* TODO: reconnect? *) + | Some socket -> + let buf = Bytes.create 2 in + let _ = recv socket buf 0 2 [] in + let i = read_ui16 buf 0 in + let buf = Bytes.create i in + let _ = recv socket buf 0 i [] in + Bytes.to_string buf + + let send_string socket s = + match socket.socket with + | None -> + failwith "no socket" (* TODO: reconnect? *) + | Some socket -> + let l = String.length s in + assert (l < 0xFFFF); + let buf = Bytes.make 2 ' ' in + Bytes.set buf 0 (Char.unsafe_chr l); + Bytes.set buf 1 (Char.unsafe_chr (l lsr 8)); + ignore(send socket buf 0 2 []); + ignore(send socket (Bytes.unsafe_of_string s) 0 (String.length s) []) +end + +(* Printing *) + + +let print_json socket json = + let b = Buffer.create 0 in + write_json (Buffer.add_string b) json; + Transport.send_string socket (Buffer.contents b) + +let output_event socket event data = + print_json socket (JsonRpc.notification event data) + +let var_to_json name value access = + let jv t v structured = + JObject ["name",JString name;"type",JString t;"value",JString v;"structured",JBool structured;"access",JString access] + in + let string_repr s = "\"" ^ (Ast.s_escape (Lazy.force s)) ^ "\"" in + let level2_value_repr = function + | VNull -> "null" + | VTrue -> "true" + | VFalse -> "false" + | VInt32 i -> Int32.to_string i + | VFloat f -> string_of_float f + | VEnumValue ve -> + let name = EvalPrinting.s_enum_ctor_name ve in + begin match ve.eargs with + | [||] -> name + | vl -> name ^ "(...)" + end + | VObject o -> "{...}" + | VString(_,s) -> string_repr s + | VArray _ | VVector _ -> "[...]" + | VInstance vi -> (rev_hash_s vi.iproto.ppath) ^ " {...}" + | VPrototype proto -> Rope.to_string (s_proto_kind proto) + | VFunction _ | VFieldClosure _ -> "" + in + let fields_string fields = + let l = List.map (fun (name, value) -> Printf.sprintf "%s: %s" (rev_hash_s name) (level2_value_repr value)) fields in + Printf.sprintf "{%s}" (String.concat ", " l) + in + let array_elems l = + let l = List.map level2_value_repr l in + Printf.sprintf "[%s]" (String.concat ", " l) + in + let value_string v = match v with + | VNull -> jv "NULL" "null" false + | VTrue -> jv "Bool" "true" false + | VFalse -> jv "Bool" "false" false + | VInt32 i -> jv "Int" (Int32.to_string i) false + | VFloat f -> jv "Float" (string_of_float f) false + | VEnumValue ve -> + let type_s = rev_hash_s ve.epath in + let name = EvalPrinting.s_enum_ctor_name ve in + let value_s,is_structured = match ve.eargs with + | [||] -> name, false + | vl -> + let l = Array.to_list (Array.map level2_value_repr vl) in + let s = Printf.sprintf "%s(%s)" name (String.concat ", " l) in + s, true + in + jv type_s value_s is_structured + | VObject o -> jv "Anonymous" (fields_string (object_fields o)) true (* TODO: false for empty structures *) + | VString(_,s) -> jv "String" (string_repr s) false + | VArray va -> jv "Array" (array_elems (EvalArray.to_list va)) true (* TODO: false for empty arrays *) + | VVector vv -> jv "Vector" (array_elems (Array.to_list vv)) true + | VInstance vi -> + let class_name = rev_hash_s vi.iproto.ppath in + jv class_name (class_name ^ " " ^ (fields_string (instance_fields vi))) true + | VPrototype proto -> jv "Anonymous" (Rope.to_string (s_proto_kind proto)) false (* TODO: show statics *) + | VFunction _ | VFieldClosure _ -> jv "Function" "" false + in + value_string value + +let get_call_stack_envs ctx kind p = + let envs = match call_stack ctx with + | _ :: envs -> envs + | [] -> [] + in + let rec loop delta envs = match envs with + | _ :: envs when delta < 0 -> loop (delta + 1) envs + | _ -> envs + in + loop ctx.debug.environment_offset_delta envs + +let output_call_stack ctx kind p = + let envs = get_call_stack_envs ctx kind p in + let id = ref (-1) in + let stack_item kind p artificial = + incr id; + let line1,col1,line2,col2 = Lexer.get_pos_coords p in + JObject [ + "id",JInt !id; + "name",JString (kind_name (get_eval ctx) kind); + "source",JString (Path.get_real_path p.pfile); + "line",JInt line1; + "column",JInt col1; + "endLine",JInt line2; + "endColumn",JInt col2; + "artificial",JBool artificial; + ] + in + let l = [stack_item kind p false] in + let stack = List.fold_left (fun acc env -> + let p = {pmin = env.env_leave_pmin; pmax = env.env_leave_pmax; pfile = rev_file_hash env.env_info.pfile} in + (stack_item env.env_info.kind p (env.env_leave_pmin < 0)) :: acc + ) l envs in + JArray (List.rev stack) + +let output_scopes capture_infos scopes = + let mk_scope id name pos = + let fl = ["id",JInt id; "name",JString name] in + let fl = + if pos <> null_pos then + let line1,col1,line2,col2 = Lexer.get_pos_coords pos in + ("pos",JObject [ + "source",JString (Path.get_real_path pos.pfile); + "line",JInt line1; + "column",JInt col1; + "endLine",JInt line2; + "endColumn",JInt col2; + ]) :: fl + else + fl + in + JObject fl + in + let _,scopes = List.fold_left (fun (id,acc) scope -> + if Hashtbl.length scope.local_infos <> 0 then + (id + 1), (mk_scope id "Locals" scope.pos) :: acc + else + (id + 1), acc + ) (1,[]) scopes in + let scopes = List.rev scopes in + let scopes = if Hashtbl.length capture_infos = 0 then scopes else (mk_scope 0 "Captures" null_pos) :: scopes in + JArray scopes + +let output_capture_vars env = + let infos = env.env_info.capture_infos in + let vars = Hashtbl.fold (fun slot name acc -> + let value = !(env.env_captures.(slot)) in + (var_to_json name value name) :: acc + ) infos [] in + JArray vars + +let output_scope_vars env scope = + let vars = Hashtbl.fold (fun local_slot name acc -> + let slot = local_slot + scope.local_offset in + let value = env.env_locals.(slot) in + (var_to_json name value name) :: acc + ) scope.local_infos [] in + JArray vars + +let output_inner_vars v access = + let children = match v with + | VNull | VTrue | VFalse | VInt32 _ | VFloat _ | VFunction _ | VFieldClosure _ -> [] + | VEnumValue ve -> + begin match ve.eargs with + | [||] -> [] + | vl -> + Array.to_list (Array.mapi (fun i v -> + let n = Printf.sprintf "[%d]" i in + let a = access ^ n in + n, v, a + ) vl) + end + | VObject o -> + let fields = object_fields o in + List.map (fun (n,v) -> + let n = rev_hash_s n in + let a = access ^ "." ^ n in + n, v, a + ) fields + | VString(_,s) -> [] + | VArray va -> + let l = EvalArray.to_list va in + List.mapi (fun i v -> + let n = Printf.sprintf "[%d]" i in + let a = access ^ n in + n, v, a + ) l + | VVector vv -> + let l = Array.to_list vv in + List.mapi (fun i v -> + let n = Printf.sprintf "[%d]" i in + let a = access ^ n in + n, v, a + ) l + | VInstance vi -> + let fields = instance_fields vi in + List.map (fun (n,v) -> + let n = rev_hash_s n in + let a = access ^ "." ^ n in + n, v, a + ) fields + | VPrototype proto -> [] (* TODO *) + in + let vars = List.map (fun (n,v,a) -> var_to_json n v a) children in + JArray vars + +type command_outcome = + | Loop of Json.t + | Run of Json.t * EvalContext.env + | Wait of Json.t * EvalContext.env + + +let make_connection socket = + (* Reads input and reacts accordingly. *) + let rec wait ctx run env = + let get_real_env ctx = + ctx.debug.environment_offset_delta <- 0; + DynArray.get (get_eval ctx).environments ((get_eval ctx).environment_offset - 1); + in + let rec loop () = + let handle_request id name params = + let error msg = + let open JsonRpc in + raise (JsonRpc_error (Custom (id, 1, msg))) + in + let invalid_params () = + let open JsonRpc in + raise (JsonRpc_error (Invalid_params id)) + in + let rec move_frame offset = + if offset < 0 || offset >= (get_eval ctx).environment_offset then begin + error (Printf.sprintf "Frame out of bounds: %i (valid range is %i - %i)" offset 0 ((get_eval ctx).environment_offset - 1)) + end else begin + ctx.debug.environment_offset_delta <- ((get_eval ctx).environment_offset - offset - 1); + Wait (JNull, (DynArray.get (get_eval ctx).environments offset)) + end + in + match name with + | "continue" -> + let env = get_real_env ctx in + ctx.debug.debug_state <- (if ctx.debug.debug_state = DbgStart then DbgRunning else DbgContinue); + Run (JNull,env) + | "stepIn" -> + let env = get_real_env ctx in + Run (JNull,env) + | "next" -> + let env = get_real_env ctx in + ctx.debug.debug_state <- DbgNext (get_eval ctx).environment_offset; + Run (JNull,env) + | "stepOut" -> + let env = get_real_env ctx in + ctx.debug.debug_state <- DbgFinish (get_eval ctx).environment_offset; + Run (JNull,env) + | "stackTrace" -> + Loop (output_call_stack ctx env.env_info.kind env.env_debug.expr.epos) + | "setBreakpoints" -> + let file, bps = + match params with + | Some (JObject fl) -> + let file = try List.find (fun (n,_) -> n = "file") fl with Not_found -> invalid_params () in + let file = match (snd file) with JString s -> s | _ -> invalid_params () in + let parse_breakpoint = function + | JObject fl -> + let line = try List.find (fun (n,_) -> n = "line") fl with Not_found -> invalid_params () in + let line = match (snd line) with JInt s -> s | _ -> invalid_params () in + let column = try Some (List.find (fun (n,_) -> n = "column") fl) with Not_found -> None in + let column = Option.map_default (fun (_,v) -> match v with JInt i -> BPColumn i | _ -> invalid_params ()) BPAny column in + line,column + | _ -> invalid_params () + in + let bps = try List.find (fun (n,_) -> n = "breakpoints") fl with Not_found -> invalid_params () in + let bps = match (snd bps) with JArray jl -> jl | _ -> invalid_params () in + let bps = List.map parse_breakpoint bps in + file, bps + | _ -> + invalid_params (); + in + let hash = hash_s (Path.unique_full_path (Common.find_file (ctx.curapi.get_com()) file)) in + let h = + try + let h = Hashtbl.find ctx.debug.breakpoints hash in + Hashtbl.clear h; + h + with Not_found -> + let h = Hashtbl.create (List.length bps) in + Hashtbl.add ctx.debug.breakpoints hash h; + h + in + let bps = List.map (fun (line,column) -> + let bp = make_breakpoint hash line BPEnabled column in + Hashtbl.add h line bp; + JObject ["id",JInt bp.bpid] + ) bps in + Loop (JArray bps) + | "setBreakpoint" -> + let file,line,column = + match params with + | Some (JObject fl) -> + let file = try List.find (fun (n,_) -> n = "file") fl with Not_found -> invalid_params () in + let file = match (snd file) with JString s -> s | _ -> invalid_params () in + let line = try List.find (fun (n,_) -> n = "line") fl with Not_found -> invalid_params () in + let line = match (snd line) with JInt s -> s | _ -> invalid_params () in + let column = try Some (List.find (fun (n,_) -> n = "column") fl) with Not_found -> None in + let column = Option.map_default (fun (_,v) -> match v with JInt i -> BPColumn i | _ -> invalid_params ()) BPAny column in + file,line,column + | _ -> + invalid_params (); + in + begin try + let breakpoint = add_breakpoint ctx file line column in + Loop (JObject ["id",JInt breakpoint.bpid]) + with Not_found -> + invalid_params (); + end + | "removeBreakpoint" -> + let id = + match params with + | Some (JObject fl) -> + let id = try List.find (fun (n,_) -> n = "id") fl with Not_found -> invalid_params () in + (match (snd id) with JInt s -> s | _ -> invalid_params ()) + | _ -> invalid_params () + in + begin try + Hashtbl.iter (fun _ h -> + let to_delete = ref [] in + Hashtbl.iter (fun k breakpoint -> if breakpoint.bpid = id then to_delete := k :: !to_delete) h; + List.iter (fun k -> Hashtbl.remove h k) !to_delete; + ) ctx.debug.breakpoints + with Not_found -> + error (Printf.sprintf "Unknown breakpoint: %d" id) + end; + Loop JNull + | "switchFrame" -> + let frame = + match params with + | Some (JObject fl) -> + let id = try List.find (fun (n,_) -> n = "id") fl with Not_found -> invalid_params () in + (match (snd id) with JInt s -> s | _ -> invalid_params ()) + | _ -> invalid_params () + in + move_frame ((get_eval ctx).environment_offset - frame - 1) + | "getScopes" -> + Loop (output_scopes env.env_info.capture_infos env.env_debug.scopes); + | "getScopeVariables" -> + let sid = + match params with + | Some (JObject fl) -> + let id = try List.find (fun (n,_) -> n = "id") fl with Not_found -> invalid_params () in + (match (snd id) with JInt s -> s | _ -> invalid_params ()) + | _ -> invalid_params () + in + begin + let vars = + try + if sid = 0 then begin + output_capture_vars env + end else begin + let scope = try List.nth env.env_debug.scopes (sid - 1) with _ -> raise Exit in + output_scope_vars env scope + end + with Exit -> + error "Invalid scope id" + in + Loop vars + end + | "getStructure" -> + let e = + match params with + | Some (JObject fl) -> + let id = try List.find (fun (n,_) -> n = "expr") fl with Not_found -> invalid_params () in + (match (snd id) with JString s -> s | _ -> invalid_params ()) + | _ -> invalid_params () + in + begin try + let e = parse_expr ctx e env.env_debug.expr.epos in + begin try + let access,v = expr_to_value ctx env e in + Loop (output_inner_vars v access) + with Exit -> + error ("Don't know how to handle this expression: " ^ (Ast.s_expr e)) + end + with Parse_expr_error e -> + error e + end + | "setVariable" -> + let expr_s,value = + match params with + | Some (JObject fl) -> + let expr = try List.find (fun (n,_) -> n = "expr") fl with Not_found -> invalid_params () in + let expr = match (snd expr) with JString s -> s | _ -> invalid_params () in + let value = try List.find (fun (n,_) -> n = "value") fl with Not_found -> invalid_params () in + let value = match (snd value) with JString s -> s | _ -> invalid_params () in + expr,value + | _ -> + invalid_params (); + in + let parse s = parse_expr ctx s env.env_debug.expr.epos in + begin try + let expr,value = parse expr_s,parse value in + begin try + let _,value = expr_to_value ctx env value in + begin match fst expr with + (* TODO: support setting array elements and enum values *) + | EField(e1,s) -> + let _,v1 = expr_to_value ctx env e1 in + set_field v1 (hash_s s) value; + Loop (var_to_json s value expr_s) + | EConst (Ident s) -> + begin try + let slot = get_var_slot_by_name env.env_debug.scopes name in + env.env_locals.(slot) <- value; + Loop (var_to_json name value s) + with Not_found -> + error ("No variable found: " ^ name); + end + | _ -> + raise Exit + end + with Exit -> + error "Don't know how to handle this expression" + end + with Parse_expr_error e -> + error e + end + | meth -> + let open JsonRpc in + raise (JsonRpc_error (Method_not_found (id, meth))) + in + let process_outcome id outcome = + let output j = print_json socket (JsonRpc.result id j) in + match outcome with + | Loop result -> + output result; + loop () + | Run (result,env) -> + output result; + run env + | Wait (result,env) -> + output result; + wait ctx run env; + in + let send_output_and_continue json = + print_json socket json; + loop (); + in + JsonRpc.handle_jsonrpc_error (fun () -> JsonRpc.process_request (Transport.read_string socket) handle_request process_outcome) send_output_and_continue; + in + loop () + in + let output_breakpoint_stop _ _ = + output_event socket "breakpointStop" None + in + let output_exception_stop _ v _ = + output_event socket "exceptionStop" (Some (JObject ["text",JString (value_string v)])) + in + { + wait = wait; + bp_stop = output_breakpoint_stop; + exc_stop = output_exception_stop; + } diff --git a/src/macro/eval/evalDecode.ml b/src/macro/eval/evalDecode.ml new file mode 100644 index 00000000000..23a0732e9bb --- /dev/null +++ b/src/macro/eval/evalDecode.ml @@ -0,0 +1,116 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open EvalValue +open EvalExceptions + +let decode_object v = match v with + | VObject o -> o + | _ -> unexpected_value v "object" + +let decode_enum v = match v with + | VEnumValue ev -> ev.eindex,Array.to_list ev.eargs + | _ -> unexpected_value v "enum" + +let decode_enum_with_pos v = match v with + | VEnumValue ev -> (ev.eindex,Array.to_list ev.eargs),(match ev.enpos with None -> null_pos | Some p -> p) + | _ -> unexpected_value v "enum" + +let decode_instance v = match v with + | VInstance vi -> vi + | _ -> unexpected_value v "instance" + +let decode_array v = match v with + | VArray va -> EvalArray.to_list va + | _ -> unexpected_value v "array" + +let decode_vector v = match v with + | VVector vv -> vv + | _ -> unexpected_value v "vector" + +let decode_varray v = match v with + | VArray va -> va + | _ -> unexpected_value v "array" + +let decode_string v = match v with + | VString(r,s) -> Lazy.force s + | _ -> unexpected_value v "string" + +let decode_rope v = match v with + | VString(s,_) -> s + | _ -> unexpected_value v "string" + +let decode_rope_string v = match v with + | VString(r,s) -> r,s + | _ -> unexpected_value v "string" + +let decode_bytes v = match v with + | VInstance {ikind=IBytes s} -> s + | _ -> unexpected_value v "string" + +let decode_i32 v = match v with + | VInt32 i -> i + | VFloat f -> (Int32.of_float f) + | _ -> unexpected_value v "int" + +let decode_int v = match v with + | VInt32 i -> Int32.to_int i + | VFloat f -> int_of_float f + | _ -> unexpected_value v "int" + +let decode_float v = match v with + | VFloat f -> f + | _ -> unexpected_value v "float" + +let decode_bool v = match v with + | VTrue -> true + | VFalse -> false + | _ -> unexpected_value v "bool" + +let default_int v vd = match v with + | VNull -> vd + | VInt32 i -> Int32.to_int i + | VFloat f -> int_of_float f + | _ -> unexpected_value v "int" + +let decode_unsafe v = match v with + | VInstance {ikind = IRef o} -> o + | _ -> unexpected_value v "unsafe" + +let decode_lazytype v = match v with + | VInstance {ikind=ILazyType(t,_)} -> t + | _ -> unexpected_value v "lazy type" + +let decode_tdecl v = match v with + | VInstance {ikind=ITypeDecl t} -> t + | _ -> unexpected_value v "type declaration" + +let decode_pos v = match v with + | VInstance {ikind=IPos p} -> p + | _ -> raise MacroApi.Invalid_expr (* maybe_decode_pos relies on this being raised *) + +let rec decode_ref v : 'a = match v with + | VInstance {ikind=IRef r} -> Obj.obj r + | _ -> unexpected_value v "unsafe" + +let num = function + | VInt32 i -> Int32.to_float i + | VFloat f -> f + | v -> unexpected_value v "number" \ No newline at end of file diff --git a/src/macro/eval/evalEmitter.ml b/src/macro/eval/evalEmitter.ml new file mode 100644 index 00000000000..61ee380ceb5 --- /dev/null +++ b/src/macro/eval/evalEmitter.ml @@ -0,0 +1,1486 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open Ast +open EvalHash +open EvalValue +open EvalEncode +open EvalDecode +open EvalContext +open EvalPrinting +open EvalExceptions +open EvalField +open EvalMisc + +type varacc = + | Local of int + | Env of int + +(* Helper *) + +let throw_string s p = + throw (encode_string s) p + +let invalid_binop op v1 v2 p = + throw_string (Printf.sprintf "Invalid operation: %s %s %s" (value_string v1) (s_binop op) (value_string v2)) p + +let unexpected_value_p v s p = + let str = Printf.sprintf "Unexpected value %s, expected %s" (value_string v) s in + throw_string str p + +let cannot_call v p = + throw (encode_string ("Cannot call " ^ (value_string v))) p + +(* Emitter *) + +let apply env exec = + exec env + +(* Objects and values *) + +let emit_null _ = vnull + +let emit_local_declaration i exec env = + env.env_locals.(i) <- exec env; + vnull + +let emit_capture_declaration i exec env = + env.env_captures.(i) <- ref (exec env); + vnull + +let emit_const v _ = v + +let emit_new_array env = + encode_array_instance (EvalArray.create [||]) + +let emit_new_vector_int i env = + encode_vector_instance (Array.make i vnull) + +let emit_new_vector exec env = + encode_vector_instance (Array.make (decode_int (exec env)) vnull) + +let emit_special_instance f execs env = + let vl = List.map (apply env) execs in + f vl + +let emit_object_declaration proto fa env = + let a = Array.make (Array.length fa) vnull in + Array.iter (fun (i,exec) -> a.(i) <- exec env) fa; + vobject { + ofields = a; + oproto = proto; + oextra = IntMap.empty; + oremoved = IntMap.empty; + } + +let emit_array_declaration execs env = + let vl = Array.map (apply env) execs in + encode_array_instance (EvalArray.create vl) + +let emit_type_expr proto env = proto + +let emit_mk_pos exec1 exec2 exec3 env = + let file = exec1 env in + let min = exec2 env in + let max = exec3 env in + encode_pos { pfile = decode_string file; pmin = decode_int min; pmax = decode_int max } + +let emit_enum_construction0 key i p env = + encode_enum_value key i [||] p + +let emit_enum_construction1 key i exec1 p env = + let v1 = exec1 env in + encode_enum_value key i [|v1|] p + +let emit_enum_construction2 key i exec1 exec2 p env = + let v1 = exec1 env in + let v2 = exec2 env in + encode_enum_value key i [|v1;v2|] p + +let emit_enum_construction3 key i exec1 exec2 exec3 p env = + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + encode_enum_value key i [|v1;v2;v3|] p + +let emit_enum_construction4 key i exec1 exec2 exec3 exec4 p env = + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + encode_enum_value key i [|v1;v2;v3;v4|] p + +let emit_enum_construction5 key i exec1 exec2 exec3 exec4 exec5 p env = + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + let v5 = exec5 env in + encode_enum_value key i [|v1;v2;v3;v4;v5|] p + +let emit_enum_construction key i execs p env = + encode_enum_value key i (Array.map (fun exec -> exec env) execs) p + +(* Branching *) + +let emit_if exec_cond exec_then exec_else env = + match exec_cond env with + | VTrue -> exec_then env + | _ -> exec_else env + +let emit_enum_switch_array exec cases exec_def p env = match exec env with + | VEnumValue ev -> + let i = ev.eindex in + if i >= Array.length cases || i < 0 then exec_def env + else (Array.unsafe_get cases i) env + | v -> + unexpected_value_p v "enum value" p + +let emit_int_switch_array exec cases exec_def p env = match exec env with + | VInt32 i32 -> + let i = Int32.to_int i32 in + if i >= Array.length cases || i < 0 then exec_def env + else (Array.unsafe_get cases i) env + | VNull -> + exec_def env + | v -> + unexpected_value_p v "int" p + +let emit_int_switch_array_shift shift exec cases exec_def p env = match exec env with + | VInt32 i32 -> + let i = Int32.to_int i32 + shift in + if i >= Array.length cases || i < 0 then exec_def env + else (Array.unsafe_get cases i) env + | VNull -> + exec_def env + | v -> + unexpected_value_p v "int" p + +let emit_int_switch_map exec cases exec_def p env = match exec env with + | VInt32 i32 -> + let i = Int32.to_int i32 in + begin try + (IntMap.find i cases) env + with Not_found -> + exec_def env + end + | v -> + unexpected_value_p v "int" p + +let emit_constant_switch exec execs constants exec_def env = + let v1 = exec env in + let rec loop v1 i = + if i >= Array.length constants then exec_def env + else if List.exists (fun v2 -> equals v1 v2) (Array.unsafe_get constants i) then + (Array.unsafe_get execs i) env + else + loop v1 (i + 1) + in + loop v1 0 + +let emit_switch exec execs patterns exec_def env = + let v1 = exec env in + let rec loop v1 i = + if i >= Array.length patterns then exec_def env + else if List.exists (fun exec -> equals v1 (exec env)) patterns.(i) then + execs.(i) env + else + loop v1 (i + 1) + in + loop v1 0 + +let emit_int_iterator slot exec1 exec2 env = + let i1 = decode_int (env.env_locals.(slot)) in + let i2 = decode_int (exec1 env) in + for i = i1 to i2 - 1 do + env.env_locals.(slot) <- vint i; + ignore(exec2 env); + done; + vnull + +let emit_int_iterator_continue slot exec1 exec2 env = + let i1 = decode_int (env.env_locals.(slot)) in + let i2 = decode_int (exec1 env) in + for i = i1 to i2 - 1 do + env.env_locals.(slot) <- vint i; + (try ignore(exec2 env) with Continue -> ()) + done; + vnull + +let emit_int_iterator_break slot exec1 exec2 env = + let i1 = decode_int (env.env_locals.(slot)) in + let i2 = decode_int (exec1 env) in + begin try + for i = i1 to i2 - 1 do + env.env_locals.(slot) <- vint i; + ignore(exec2 env); + done; + with Break -> + () + end; + vnull + +let emit_int_iterator_break_continue slot exec1 exec2 env = + let i1 = decode_int (env.env_locals.(slot)) in + let i2 = decode_int (exec1 env) in + begin try + for i = i1 to i2 - 1 do + env.env_locals.(slot) <- vint i; + (try ignore(exec2 env) with Continue -> ()) + done; + with Break -> + () + end; + vnull + +let emit_while_gte exec1 f exec2 env = + while (num (exec1 env) >= f) do exec2 env done; + vnull + +let rec run_while_continue exec_cond exec_body env = + try + while is_true (exec_cond env) do exec_body env done; + with Continue -> + run_while_continue exec_cond exec_body env + +let emit_while exec_cond exec_body env = + while is_true (exec_cond env) do exec_body env done; + vnull + +let emit_while_break exec_cond exec_body env = + begin try + while is_true (exec_cond env) do exec_body env done; + with Break -> + () + end; + vnull + +let emit_while_continue exec_cond exec_body env = + run_while_continue exec_cond exec_body env; + vnull + +let emit_while_break_continue exec_cond exec_body env = + (try run_while_continue exec_cond exec_body env with Break -> ()); + vnull + +let emit_do_while exec_cond exec_body env = + ignore(exec_body env); + while is_true (exec_cond env) do exec_body env done; + vnull + +let emit_do_while_break exec_cond exec_body env = + begin try + ignore(exec_body env); + while is_true (exec_cond env) do exec_body env done; + with Break -> + () + end; + vnull + +let emit_do_while_continue exec_cond exec_body env = + (try ignore(exec_body env) with Continue -> ()); + run_while_continue exec_cond exec_body env; + vnull + +let emit_do_while_break_continue exec_cond exec_body env = + begin try + ignore(exec_body env); run_while_continue exec_cond exec_body env + with + | Break -> () + | Continue -> run_while_continue exec_cond exec_body env + end; + vnull + +let emit_try exec catches env = + let ctx = get_ctx() in + let eval = get_eval ctx in + let environment_offset = eval.environment_offset in + if ctx.debug.support_debugger then begin + List.iter (fun (_,path,_) -> Hashtbl.add ctx.debug.caught_types path true) catches + end; + let restore () = + List.iter (fun (_,path,_) -> Hashtbl.remove ctx.debug.caught_types path) catches + in + let v = try + let v = exec env in + restore(); + v + with RunTimeException(v,_,_) as exc -> + restore(); + build_exception_stack ctx environment_offset; + eval.environment_offset <- environment_offset; + let exec,_,varacc = + try + List.find (fun (_,path,i) -> is v path) catches + with Not_found -> + raise exc + in + begin match varacc with + | Local slot -> env.env_locals.(slot) <- v + | Env slot -> env.env_captures.(slot) <- ref v + end; + exec env + in + v + +(* Control flow *) + +let emit_block1 exec1 env = + exec1 env + +let emit_block2 exec1 exec2 env = + ignore(exec1 env); + exec2 env + +let emit_block3 exec1 exec2 exec3 env = + ignore(exec1 env); + ignore(exec2 env); + exec3 env + +let emit_block4 exec1 exec2 exec3 exec4 env = + ignore(exec1 env); + ignore(exec2 env); + ignore(exec3 env); + exec4 env + +let emit_block5 exec1 exec2 exec3 exec4 exec5 env = + ignore(exec1 env); + ignore(exec2 env); + ignore(exec3 env); + ignore(exec4 env); + exec5 env + +let emit_block execs env = + let l = Array.length execs in + for i = 0 to l - 2 do + ignore((Array.unsafe_get execs i) env) + done; + (Array.unsafe_get execs (l -1)) env + +let emit_value exec env = + exec env + +let emit_return_null _ = raise (Return vnull) + +let emit_return_value exec env = raise (Return (exec env)) + +let emit_break env = raise Break + +let emit_continue env = raise Continue + +let emit_throw exec p env = throw (exec env) p + +let emit_safe_cast exec t p env = + let v1 = exec env in + if not (is v1 t) then throw_string "Class cast error" p; + v1 + +(* Calls *) + +(* super.call() - immediate *) + +let emit_super_field_call slot proto i execs p env = + let vthis = env.env_locals.(slot) in + let vf = proto.pfields.(i) in + let vl = List.map (fun f -> f env) execs in + call_value_on vthis vf vl + +(* Type.call() - immediate *) + +let call0 v p env = + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + match v with + | VFunction (Fun0 f,_) -> f () + | VFunction (FunN f,_) -> f [] + | VFieldClosure(v0,f) -> call_function f [v0] + | VInstance {ikind = ILazyType(_,get)} -> get() + | _ -> cannot_call v p + +let call1 v v1 p env = + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + match v with + | VFunction (Fun1 f,_) -> f v1 + | VFunction (FunN f,_) -> f [v1] + | VFieldClosure(v0,f) -> call_function f [v0;v1] + | _ -> cannot_call v p + +let call2 v v1 v2 p env = + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + match v with + | VFunction (Fun2 f,_) -> f v1 v2 + | VFunction (FunN f,_) -> f [v1;v2] + | VFieldClosure(v0,f) -> call_function f [v0;v1;v2] + | _ -> cannot_call v p + +let call3 v v1 v2 v3 p env = + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + match v with + | VFunction (Fun3 f,_) -> f v1 v2 v3 + | VFunction (FunN f,_) -> f [v1;v2;v3] + | VFieldClosure(v0,f) -> call_function f [v0;v1;v2;v3] + | _ -> cannot_call v p + +let call4 v v1 v2 v3 v4 p env = + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + match v with + | VFunction (Fun4 f,_) -> f v1 v2 v3 v4 + | VFunction (FunN f,_) -> f [v1;v2;v3;v4] + | VFieldClosure(v0,f) -> call_function f [v0;v1;v2;v3;v4] + | _ -> cannot_call v p + +let call5 v v1 v2 v3 v4 v5 p env = + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + match v with + | VFunction (Fun5 f,_) -> f v1 v2 v3 v4 v5 + | VFunction (FunN f,_) -> f [v1;v2;v3;v4;v5] + | VFieldClosure(v0,f) -> call_function f [v0;v1;v2;v3;v4;v5] + | _ -> cannot_call v p + +let emit_proto_field_call proto i execs p = + match execs with + | [] -> + let vf = lazy (match proto.pfields.(i) with VFunction (Fun0 f,_) -> f | v -> cannot_call v p) in + (fun env -> + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + (Lazy.force vf) () + ) + | [exec1] -> + let vf = lazy (match proto.pfields.(i) with VFunction (Fun1 f,_) -> f | v -> cannot_call v p) in + (fun env -> + let f = Lazy.force vf in + let v1 = exec1 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + f v1 + ) + | [exec1;exec2] -> + let vf = lazy (match proto.pfields.(i) with VFunction (Fun2 f,_) -> f | v -> cannot_call v p) in + (fun env -> + let f = Lazy.force vf in + let v1 = exec1 env in + let v2 = exec2 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + f v1 v2 + ) + | [exec1;exec2;exec3] -> + let vf = lazy (match proto.pfields.(i) with VFunction (Fun3 f,_) -> f | v -> cannot_call v p) in + (fun env -> + let f = Lazy.force vf in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + f v1 v2 v3 + ) + | [exec1;exec2;exec3;exec4] -> + let vf = lazy (match proto.pfields.(i) with VFunction (Fun4 f,_) -> f | v -> cannot_call v p) in + (fun env -> + let f = Lazy.force vf in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + f v1 v2 v3 v4 + ) + | [exec1;exec2;exec3;exec4;exec5] -> + let vf = lazy (match proto.pfields.(i) with VFunction (Fun5 f,_) -> f | v -> cannot_call v p) in + (fun env -> + let f = Lazy.force vf in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + let v5 = exec5 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + f v1 v2 v3 v4 v5 + ) + | _ -> + let vf = lazy (match proto.pfields.(i) with VFunction (FunN f,_) -> f | v -> cannot_call v p) in + (fun env -> + let f = Lazy.force vf in + let vl = List.map (fun exec -> exec env) execs in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + f vl + ) + +(* instance.call() where call is overridden - dynamic dispatch *) + +let emit_method_call exec name execs p = + let vf vthis = match vthis with + | VInstance {iproto = proto} | VPrototype proto -> proto_field_raise proto name + | VString _ -> proto_field_raise (get_ctx()).string_prototype name + | _ -> unexpected_value_p vthis "instance" p + in + match execs with + | [] -> + (fun env -> + let vthis = exec env in + let vf = vf vthis in + call1 vf vthis p env + ) + | [exec1] -> + (fun env -> + let vthis = exec env in + let vf = vf vthis in + let v1 = exec1 env in + call2 vf vthis v1 p env + ) + | [exec1;exec2] -> + (fun env -> + let vthis = exec env in + let vf = vf vthis in + let v1 = exec1 env in + let v2 = exec2 env in + call3 vf vthis v1 v2 p env + ) + | [exec1;exec2;exec3] -> + (fun env -> + let vthis = exec env in + let vf = vf vthis in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + call4 vf vthis v1 v2 v3 p env + ) + | [exec1;exec2;exec3;exec4] -> + (fun env -> + let vthis = exec env in + let vf = vf vthis in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + call5 vf vthis v1 v2 v3 v4 p env + ) + | _ -> + (fun env -> + let vthis = exec env in + let vf = vf vthis in + let vl = List.map (apply env) execs in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + call_value_on vthis vf vl + ) + +(* instance.call() where call is not a method - lookup + this-binding *) + +let emit_field_call exec name execs p env = + let vthis = exec env in + let vf = field vthis name in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + call_value_on vthis vf (List.map (apply env) execs) + +(* new() - immediate + this-binding *) + +let emit_constructor_call0 proto vf p env = + let vthis = create_instance_direct proto in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore((Lazy.force vf) vthis); + vthis + +let emit_constructor_call1 proto vf exec1 p env = + let f = Lazy.force vf in + let vthis = create_instance_direct proto in + let v1 = exec1 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f vthis v1); + vthis + +let emit_constructor_call2 proto vf exec1 exec2 p env = + let f = Lazy.force vf in + let vthis = create_instance_direct proto in + let v1 = exec1 env in + let v2 = exec2 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f vthis v1 v2); + vthis + +let emit_constructor_call3 proto vf exec1 exec2 exec3 p env = + let f = Lazy.force vf in + let vthis = create_instance_direct proto in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f vthis v1 v2 v3); + vthis + +let emit_constructor_call4 proto vf exec1 exec2 exec3 exec4 p env = + let f = Lazy.force vf in + let vthis = create_instance_direct proto in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f vthis v1 v2 v3 v4); + vthis + +let emit_constructor_callN proto vf execs p env = + let f = Lazy.force vf in + let vthis = create_instance_direct proto in + let vl = List.map (fun exec -> exec env) execs in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f (vthis :: vl)); + vthis + +let emit_constructor_call proto fnew execs p = + match execs with + | [] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun1 f,_) -> f | v -> cannot_call v p) in + emit_constructor_call0 proto vf p + | [exec1] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun2 f,_) -> f | v -> cannot_call v p) in + emit_constructor_call1 proto vf exec1 p + | [exec1;exec2] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun3 f,_) -> f | v -> cannot_call v p) in + emit_constructor_call2 proto vf exec1 exec2 p + | [exec1;exec2;exec3] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun4 f,_) -> f | v -> cannot_call v p) in + emit_constructor_call3 proto vf exec1 exec2 exec3 p + | [exec1;exec2;exec3;exec4] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun5 f,_) -> f | v -> cannot_call v p) in + emit_constructor_call4 proto vf exec1 exec2 exec3 exec4 p + | _ -> + let vf = lazy (match Lazy.force fnew with VFunction (FunN f,_) -> f | v -> cannot_call v p) in + emit_constructor_callN proto vf execs p + +(* super() - immediate + this-binding *) + +let emit_super_call0 vf p env = + let vthis = env.env_locals.(0) in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore((Lazy.force vf) vthis); + vthis + +let emit_super_call1 vf exec1 p env = + let f = Lazy.force vf in + let vthis = env.env_locals.(0) in + let v1 = exec1 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f vthis v1); + vthis + +let emit_super_call2 vf exec1 exec2 p env = + let f = Lazy.force vf in + let vthis = env.env_locals.(0) in + let v1 = exec1 env in + let v2 = exec2 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f vthis v1 v2); + vthis + +let emit_super_call3 vf exec1 exec2 exec3 p env = + let f = Lazy.force vf in + let vthis = env.env_locals.(0) in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f vthis v1 v2 v3); + vthis + +let emit_super_call4 vf exec1 exec2 exec3 exec4 p env = + let f = Lazy.force vf in + let vthis = env.env_locals.(0) in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f vthis v1 v2 v3 v4); + vthis + +let emit_super_callN vf execs p env = + let f = Lazy.force vf in + let vthis = env.env_locals.(0) in + let vl = List.map (fun exec -> exec env) execs in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + ignore(f (vthis :: vl)); + vthis + +let emit_super_call fnew execs p = + match execs with + | [] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun1 f,_) -> f | v -> cannot_call v p) in + emit_super_call0 vf p + | [exec1] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun2 f,_) -> f | v -> cannot_call v p) in + emit_super_call1 vf exec1 p + | [exec1;exec2] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun3 f,_) -> f | v -> cannot_call v p) in + emit_super_call2 vf exec1 exec2 p + | [exec1;exec2;exec3] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun4 f,_) -> f | v -> cannot_call v p) in + emit_super_call3 vf exec1 exec2 exec3 p + | [exec1;exec2;exec3;exec4] -> + let vf = lazy (match Lazy.force fnew with VFunction (Fun5 f,_) -> f | v -> cannot_call v p) in + emit_super_call4 vf exec1 exec2 exec3 exec4 p + | _ -> + let vf = lazy (match Lazy.force fnew with VFunction (FunN f,_) -> f | v -> cannot_call v p) in + emit_super_callN vf execs p + +(* unknown call - full lookup *) + +let emit_call0 exec p env = + call0 (exec env) p env + +let emit_call1 exec exec1 p env = + let v0 = exec env in + let v1 = exec1 env in + call1 v0 v1 p env + +let emit_call2 exec exec1 exec2 p env = + let v0 = exec env in + let v1 = exec1 env in + let v2 = exec2 env in + call2 v0 v1 v2 p env + +let emit_call3 exec exec1 exec2 exec3 p env = + let v0 = exec env in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + call3 v0 v1 v2 v3 p env + +let emit_call4 exec exec1 exec2 exec3 exec4 p env = + let v0 = exec env in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + call4 v0 v1 v2 v3 v4 p env + +let emit_call5 exec exec1 exec2 exec3 exec4 exec5 p env = + let v0 = exec env in + let v1 = exec1 env in + let v2 = exec2 env in + let v3 = exec3 env in + let v4 = exec4 env in + let v5 = exec5 env in + call5 v0 v1 v2 v3 v4 v5 p env + +let emit_call exec execs p env = + let v1 = exec env in + env.env_leave_pmin <- p.pmin; + env.env_leave_pmax <- p.pmax; + call_value v1 (List.map (apply env) execs) + +(* Read *) + +let emit_local_read i env = env.env_locals.(i) + +let emit_capture_read i env = !(env.env_captures.(i)) + +let emit_array_length_read exec env = match exec env with + | VArray va -> vint (va.alength) + | v -> unexpected_value v "Array" + +let emit_vector_length_read exec env = match exec env with + | VVector vv -> vint (Array.length vv) + | v -> unexpected_value v "Vector" + +let emit_bytes_length_read exec env = match exec env with + | VInstance {ikind = IBytes s} -> vint (Bytes.length s) + | v -> unexpected_value v "Bytes" + +let emit_proto_field_read proto i env = + proto.pfields.(i) + +let emit_instance_local_field_read iv i env = match env.env_locals.(iv) with + | VInstance vi -> vi.ifields.(i) + | VString(_,s) -> vint (String.length (Lazy.force s)) + | v -> unexpected_value v "instance" + +let emit_instance_field_read exec i env = match exec env with + | VInstance vi -> vi.ifields.(i) + | VString(_,s) -> vint (String.length (Lazy.force s)) + | v -> unexpected_value v "instance" + +let emit_field_closure exec name env = + let v = exec env in + dynamic_field v name + +let emit_anon_local_field_read iv proto i name p env = + match env.env_locals.(iv) with + | VObject o -> + if proto == o.oproto then o.ofields.(i) + else object_field o name + | VNull -> throw_string "field access on null" p + | v -> field v name + +let emit_anon_field_read exec proto i name p env = + match exec env with + | VObject o -> + if proto == o.oproto then o.ofields.(i) + else object_field o name + | VNull -> throw_string "field access on null" p + | v -> field v name + +let emit_field_read exec name p env = match exec env with + | VNull -> throw_string "field access on null" p + | v -> field v name + +let emit_array_local_read i exec2 env = + let va = env.env_locals.(i) in + let vi = exec2 env in + let i = decode_int vi in + if i < 0 then vnull + else EvalArray.get (decode_varray va) i + +let emit_array_read exec1 exec2 env = + let va = exec1 env in + let vi = exec2 env in + let i = decode_int vi in + if i < 0 then vnull + else EvalArray.get (decode_varray va) i + +let emit_vector_local_read i exec2 env = + let vv = env.env_locals.(i) in + let vi = exec2 env in + let i = decode_int vi in + if i < 0 then vnull + else Array.unsafe_get (decode_vector vv) i + +let emit_vector_read exec1 exec2 env = + let vv = exec1 env in + let vi = exec2 env in + let i = decode_int vi in + if i < 0 then vnull + else Array.unsafe_get (decode_vector vv) i + +let emit_enum_index exec env = match exec env with + | VEnumValue ev -> vint ev.eindex + | v -> unexpected_value v "enum value" + +let emit_enum_parameter_read exec i env = match exec env with + | VEnumValue ev -> (try ev.eargs.(i) with Not_found -> vnull) + | v1 -> unexpected_value v1 "enum value" + +let emit_string_cca exec1 exec2 p env = + let s = decode_string (exec1 env) in + let index = decode_int (exec2 env) in + if index >= String.length s then vnull + else vint (int_of_char s.[index]) + +(* Write *) + +let emit_local_write slot exec env = + let v = exec env in + env.env_locals.(slot) <- v; + v + +let emit_capture_write slot exec env = + let v = exec env in + env.env_captures.(slot) := v; + v + +let emit_proto_field_write proto i exec2 env = + let v = exec2 env in + proto.pfields.(i) <- v; + v + +let emit_array_length_write exec1 exec2 env = + let va = exec1 env in + let v2 = exec2 env in + EvalArray.set_length (decode_varray va) (decode_int v2); + v2 + +let emit_instance_field_write exec1 i exec2 env = match exec1 env with + | VInstance vi -> + let v = exec2 env in + vi.ifields.(i) <- v; + v + | v -> unexpected_value v "instance" + +let emit_anon_field_write exec1 proto i name exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + begin match v1 with + | VObject o -> + if proto == o.oproto then begin + o.ofields.(i) <- v2; + o.oremoved <- IntMap.remove name o.oremoved; + end else set_object_field o name v2 + | _ -> + set_field v1 name v2; + end; + v2 + +let emit_field_write exec1 name exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + set_field v1 name v2; + v2 + +let emit_array_local_write i exec2 exec3 p env = + let va = env.env_locals.(i) in + let vi = exec2 env in + let v3 = exec3 env in + let i = decode_int vi in + if i < 0 then throw_string (Printf.sprintf "Negative array index: %i" i) p; + EvalArray.set (decode_varray va) i v3; + v3 + +let emit_array_write exec1 exec2 exec3 p env = + let va = exec1 env in + let vi = exec2 env in + let v3 = exec3 env in + let i = decode_int vi in + if i < 0 then throw_string (Printf.sprintf "Negative array index: %i" i) p; + EvalArray.set (decode_varray va) i v3; + v3 + +let emit_vector_local_write i exec2 exec3 p env = + let vv = env.env_locals.(i) in + let vi = exec2 env in + let v3 = exec3 env in + let i = decode_int vi in + if i < 0 then throw_string (Printf.sprintf "Negative vector index: %i" i) p; + Array.unsafe_set (decode_vector vv) i v3; + v3 + +let emit_vector_write exec1 exec2 exec3 p env = + let vv = exec1 env in + let vi = exec2 env in + let v3 = exec3 env in + let i = decode_int vi in + if i < 0 then throw_string (Printf.sprintf "Negative vector index: %i" i) p; + Array.unsafe_set (decode_vector vv) i v3; + v3 + +(* Read + write *) + +let emit_local_read_write slot exec fop prefix env = + let v1 = env.env_locals.(slot) in + let v2 = exec env in + let v = fop v1 v2 in + env.env_locals.(slot) <- v; + if prefix then v else v1 + +let emit_local_incr_postfix slot env = + let vi = env.env_locals.(slot) in + env.env_locals.(slot) <- vint32 (Int32.succ (decode_i32 vi)); + vi + +let emit_local_incr_prefix slot env = + let vi = env.env_locals.(slot) in + let v = vint32 (Int32.succ (decode_i32 vi)) in + env.env_locals.(slot) <- v; + v + +let emit_local_decr_postfix slot env = + let vi = env.env_locals.(slot) in + env.env_locals.(slot) <- vint32 (Int32.pred (decode_i32 vi)); + vi + +let emit_local_decr_prefix slot env = + let vi = env.env_locals.(slot) in + let v = vint32 (Int32.pred (decode_i32 vi)) in + env.env_locals.(slot) <- v; + v + +let emit_capture_read_write slot exec fop prefix env = + let v1 = !(env.env_captures.(slot)) in + let v2 = exec env in + let v = fop v1 v2 in + env.env_captures.(slot) := v; + if prefix then v else v1 + +let emit_capture_incr_postfix slot env = + let vi = !(env.env_captures.(slot)) in + env.env_captures.(slot) := vint32 (Int32.succ (decode_i32 vi)); + vi + +let emit_capture_incr_prefix slot env = + let vi = !(env.env_captures.(slot)) in + let v = vint32 (Int32.succ (decode_i32 vi)) in + env.env_captures.(slot) := v; + v + +let emit_capture_decr_postfix slot env = + let vi = !(env.env_captures.(slot)) in + env.env_captures.(slot) := vint32 (Int32.pred (decode_i32 vi)); + vi + +let emit_capture_decr_prefix slot env = + let vi = !(env.env_captures.(slot)) in + let v = vint32 (Int32.pred (decode_i32 vi)) in + env.env_captures.(slot) := v; + v + +let emit_proto_field_read_write proto i exec2 fop prefix env = + let vf = proto.pfields.(i) in + let v2 = exec2 env in + let v = fop vf v2 in + proto.pfields.(i) <- v; + if prefix then v else vf + +let instance_field_read_write vi i exec2 fop prefix env = + let vf = vi.ifields.(i) in + let v2 = exec2 env in + let v = fop vf v2 in + vi.ifields.(i) <- v; + if prefix then v else vf + +let emit_instance_field_read_write exec1 i exec2 fop prefix env = match exec1 env with + | VInstance vi -> instance_field_read_write vi i exec2 fop prefix env + | v -> unexpected_value v "instance" + +let emit_field_read_write exec1 name exec2 fop prefix env = + let v1 = exec1 env in + match v1 with + | VObject o -> + let vf = object_field o name in + let v2 = exec2 env in + let v = fop vf v2 in + set_object_field o name v; + if prefix then v else vf + | VInstance vi -> + let i = get_instance_field_index vi.iproto name in + instance_field_read_write vi i exec2 fop prefix env + | VPrototype proto -> + let i = get_proto_field_index proto name in + emit_proto_field_read_write proto i exec2 fop prefix env + | _ -> + let vf = field v1 name in + let v2 = exec2 env in + let v = fop vf v2 in + set_field v1 name v; + if prefix then v else vf + +let emit_array_local_read_write i exec2 exec3 fop prefix p env = + let va1 = env.env_locals.(i) in + let va2 = exec2 env in + let va = decode_varray va1 in + let i = decode_int va2 in + if i < 0 then throw_string (Printf.sprintf "Negative array index: %i" i) p; + let v = EvalArray.get va i in + let v2 = exec3 env in + let v3 = fop v v2 in + EvalArray.set va i v3; + if prefix then v3 else v + +let emit_array_read_write exec1 exec2 exec3 fop prefix p env = + let va1 = exec1 env in + let va2 = exec2 env in + let va = decode_varray va1 in + let i = decode_int va2 in + if i < 0 then throw_string (Printf.sprintf "Negative array index: %i" i) p; + let v = EvalArray.get va i in + let v2 = exec3 env in + let v3 = fop v v2 in + EvalArray.set va i v3; + if prefix then v3 else v + +let emit_vector_local_read_write i exec2 exec3 fop prefix p env = + let va1 = env.env_locals.(i) in + let va2 = exec2 env in + let va = decode_vector va1 in + let i = decode_int va2 in + if i < 0 then throw_string (Printf.sprintf "Negative vector index: %i" i) p; + let v = Array.unsafe_get va i in + let v2 = exec3 env in + let v3 = fop v v2 in + Array.unsafe_set va i v3; + if prefix then v3 else v + +let emit_vector_read_write exec1 exec2 exec3 fop prefix p env = + let va1 = exec1 env in + let va2 = exec2 env in + let va = decode_vector va1 in + let i = decode_int va2 in + if i < 0 then throw_string (Printf.sprintf "Negative vector index: %i" i) p; + let v = Array.unsafe_get va i in + let v2 = exec3 env in + let v3 = fop v v2 in + Array.unsafe_set va i v3; + if prefix then v3 else v + +(* Ops *) + +let emit_eq_null exec env = match exec env with + | VNull -> VTrue + | _ -> VFalse + +let emit_not_eq_null exec env = match exec env with + | VNull -> VFalse + | _ -> VTrue + +let op_add v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.add i1 i2) + | VFloat f1,VFloat f2 -> vfloat (f1 +. f2) + | VInt32 i,VFloat f | VFloat f,VInt32 i -> vfloat ((Int32.to_float i) +. f) + | VString(s1,_),VString(s2,_) -> encode_rope (Rope.concat2 s1 s2) + | VString(s1,_),v2 -> encode_rope (Rope.concat2 s1 (s_value 0 v2)) + | v1,VString(s2,_) -> encode_rope (Rope.concat2 (s_value 0 v1) s2) + | v1,v2 -> encode_rope (Rope.concat2 (s_value 0 v1) (s_value 0 v2)) + +let op_mult p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.mul i1 i2) + | VFloat f1,VFloat f2 -> vfloat (f1 *. f2) + | VInt32 i,VFloat f | VFloat f,VInt32 i -> vfloat ((Int32.to_float i) *. f) + | _ -> invalid_binop OpMult v1 v2 p + +let op_div p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vfloat ((Int32.to_float i1) /. (Int32.to_float i2)) + | VFloat f1,VFloat f2 -> vfloat (f1 /. f2) + | VInt32 i1,VFloat f2 -> vfloat ((Int32.to_float i1) /. f2) + | VFloat f1,VInt32 i2 -> vfloat (f1 /. (Int32.to_float i2)) + | _ -> invalid_binop OpDiv v1 v2 p + +let op_sub p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.sub i1 i2) + | VFloat f1,VFloat f2 -> vfloat (f1 -. f2) + | VInt32 i1,VFloat f2 -> vfloat ((Int32.to_float i1) -. f2) + | VFloat f1,VInt32 i2 -> vfloat (f1 -. (Int32.to_float i2)) + | _ -> invalid_binop OpSub v1 v2 p + +let op_eq v1 v2 = vbool (equals v1 v2) + +let op_not_eq v1 v2 = vbool (not (equals v1 v2)) + +let op_gt v1 v2 = vbool (compare v1 v2 = CSup) + +let op_gte v1 v2 = vbool (match compare v1 v2 with CSup | CEq -> true | _ -> false) + +let op_lt v1 v2 = vbool (compare v1 v2 = CInf) + +let op_lte v1 v2 = vbool (match compare v1 v2 with CInf | CEq -> true | _ -> false) + +let op_and p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.logand i1 i2) + | _ -> invalid_binop OpAnd v1 v2 p + +let op_or p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.logor i1 i2) + | _ -> invalid_binop OpOr v1 v2 p + +let op_xor p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.logxor i1 i2) + | _ -> invalid_binop OpXor v1 v2 p + +let op_shl p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.shift_left i1 (Int32.to_int i2)) + | _ -> invalid_binop OpShl v1 v2 p + +let op_shr p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.shift_right i1 (Int32.to_int i2)) + | _ -> invalid_binop OpShr v1 v2 p + +let op_ushr p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.shift_right_logical i1 (Int32.to_int i2)) + | _ -> invalid_binop OpUShr v1 v2 p + +let op_mod p v1 v2 = match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.rem i1 i2) + | VFloat f1,VFloat f2 -> vfloat (mod_float f1 f2) + | VInt32 i1,VFloat f2 -> vfloat (mod_float (Int32.to_float i1) f2) + | VFloat f1,VInt32 i2 -> vfloat (mod_float f1 (Int32.to_float i2)) + | _ -> invalid_binop OpMod v1 v2 p + +let emit_op_add exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_add v1 v2 + +let emit_op_mult p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_mult p v1 v2 + +let emit_op_div p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_div p v1 v2 + +let emit_op_sub p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_sub p v1 v2 + +let emit_op_eq exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + vbool (equals v1 v2) + +let emit_op_not_eq exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + vbool (not (equals v1 v2)) + +let emit_op_gt exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + vbool (compare v1 v2 = CSup) + +let emit_op_gte exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + vbool (match compare v1 v2 with CSup | CEq -> true | _ -> false) + +let emit_op_lt exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + vbool (compare v1 v2 = CInf) + +let emit_op_lte exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + vbool (match compare v1 v2 with CInf | CEq -> true | _ -> false) + +let emit_op_and p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_and p v1 v2 + +let emit_op_or p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_or p v1 v2 + +let emit_op_xor p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_xor p v1 v2 + +let emit_op_shl p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_shl p v1 v2 + +let emit_op_shr p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_shr p v1 v2 + +let emit_op_ushr p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_ushr p v1 v2 + +let emit_op_mod p exec1 exec2 env = + let v1 = exec1 env in + let v2 = exec2 env in + op_mod p v1 v2 + +let emit_not exec env = match exec env with + | VNull | VFalse -> VTrue + | _ -> VFalse + +let emit_bool_and exec1 exec2 env = + if is_true (exec1 env) then exec2 env + else VFalse + +let emit_bool_or exec1 exec2 env = + if is_true (exec1 env) then VTrue + else exec2 env + +let emit_neg exec p env = match exec env with + | VFloat f -> vfloat (-.f) + | VInt32 i -> vint32 (Int32.neg i) + | _ -> throw_string "Invalid operation" p + +(* Function *) + +let handle_capture_arguments exec varaccs env = + List.iter (fun (slot,i) -> + env.env_captures.(i) <- ref env.env_locals.(slot) + ) varaccs; + exec env + +let run_function ctx exec env = + let v = try + exec env + with + | Return v -> v + in + env.env_in_use <- false; + pop_environment ctx env; + v +[@@inline] + +let run_function_noret ctx exec env = + let v = exec env in + env.env_in_use <- false; + pop_environment ctx env; + v +[@@inline] + +let get_normal_env ctx info num_locals num_captures _ = + push_environment ctx info num_locals num_captures + +let get_closure_env ctx info num_locals num_captures refs = + let env = push_environment ctx info num_locals num_captures in + Array.iteri (fun i vr -> env.env_captures.(i) <- vr) refs; + env + +let get_normal_env_opt ctx default_env info num_locals num_captures _ = + if default_env.env_in_use then begin + push_environment ctx info num_locals num_captures + end else begin + default_env.env_in_use <- true; + default_env + end + +let get_closure_env_opt ctx default_env info num_locals num_captures refs = + let env = if default_env.env_in_use then begin + push_environment ctx info num_locals num_captures + end else begin + default_env.env_in_use <- true; + default_env + end in + Array.iteri (fun i vr -> env.env_captures.(i) <- vr) refs; + env + +let create_function ctx num_args get_env hasret refs exec = + match num_args with + | 0 -> + if hasret then Fun0 (fun () -> + let env = get_env refs in + run_function ctx exec env + ) + else Fun0 (fun () -> + let env = get_env refs in + run_function_noret ctx exec env + ) + | 1 -> + if hasret then Fun1 (fun v1 -> + let env = get_env refs in + env.env_locals.(0) <- v1; + run_function ctx exec env + ) + else Fun1 (fun v1 -> + let env = get_env refs in + env.env_locals.(0) <- v1; + run_function_noret ctx exec env + ) + | 2 -> + let run v1 v2 = + let env = get_env refs in + env.env_locals.(0) <- v1; + env.env_locals.(1) <- v2; + env + in + if hasret then Fun2 (fun v1 v2 -> + let env = run v1 v2 in + run_function ctx exec env + ) + else Fun2 (fun v1 v2 -> + let env = run v1 v2 in + run_function_noret ctx exec env + ) + | 3 -> + let run v1 v2 v3 = + let env = get_env refs in + env.env_locals.(0) <- v1; + env.env_locals.(1) <- v2; + env.env_locals.(2) <- v3; + env + in + if hasret then Fun3 (fun v1 v2 v3 -> + let env = run v1 v2 v3 in + run_function ctx exec env + ) + else Fun3 (fun v1 v2 v3 -> + let env = run v1 v2 v3 in + run_function_noret ctx exec env + ) + | 4 -> + let run v1 v2 v3 v4 = + let env = get_env refs in + env.env_locals.(0) <- v1; + env.env_locals.(1) <- v2; + env.env_locals.(2) <- v3; + env.env_locals.(3) <- v4; + env + in + if hasret then Fun4 (fun v1 v2 v3 v4 -> + let env = run v1 v2 v3 v4 in + run_function ctx exec env + ) + else Fun4 (fun v1 v2 v3 v4 -> + let env = run v1 v2 v3 v4 in + run_function_noret ctx exec env + ) + | 5 -> + let run v1 v2 v3 v4 v5 = + let env = get_env refs in + env.env_locals.(0) <- v1; + env.env_locals.(1) <- v2; + env.env_locals.(2) <- v3; + env.env_locals.(3) <- v4; + env.env_locals.(4) <- v5; + env + in + if hasret then Fun5 (fun v1 v2 v3 v4 v5 -> + let env = run v1 v2 v3 v4 v5 in + run_function ctx exec env + ) + else Fun5 (fun v1 v2 v3 v4 v5 -> + let env = run v1 v2 v3 v4 v5 in + run_function_noret ctx exec env + ) + | _ -> + if hasret then FunN (fun vl -> + let env = get_env refs in + List.iteri (fun i v -> + env.env_locals.(i) <- v + ) vl; + run_function ctx exec env + ) + else FunN (fun vl -> + let env = get_env refs in + List.iteri (fun i v -> + env.env_locals.(i) <- v + ) vl; + run_function_noret ctx exec env + ) + +let emit_closure ctx num_captures num_args get_env hasret exec env = + let refs = Array.sub env.env_captures 0 num_captures in + let f = create_function ctx num_args get_env hasret refs exec in + vstatic_function f \ No newline at end of file diff --git a/src/macro/eval/evalEncode.ml b/src/macro/eval/evalEncode.ml new file mode 100644 index 00000000000..62b2c2887a6 --- /dev/null +++ b/src/macro/eval/evalEncode.ml @@ -0,0 +1,198 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open EvalValue +open EvalExceptions +open EvalContext +open EvalHash + +(* Functions *) + +let vifun0 f = vfunction (Fun1 (fun a -> f a)) +let vifun1 f = vfunction (Fun2 (fun a b -> f a b)) +let vifun2 f = vfunction (Fun3 (fun a b c -> f a b c)) +let vifun3 f = vfunction (Fun4 (fun a b c d -> f a b c d)) +let vifun4 f = vfunction (Fun5 (fun a b c d e -> f a b c d e)) + +let vfun0 f = vstatic_function (Fun0 (fun vl -> f ())) +let vfun1 f = vstatic_function (Fun1 (fun a -> f a)) +let vfun2 f = vstatic_function (Fun2 (fun a b -> f a b)) +let vfun3 f = vstatic_function (Fun3 (fun a b c -> f a b c)) +let vfun4 f = vstatic_function (Fun4 (fun a b c d -> f a b c d)) +let vfun5 f = vstatic_function (Fun5 (fun a b c d e -> f a b c d e)) + +(* Objects *) + +let encode_obj _ l = + let ctx = get_ctx() in + let proto,sorted = ctx.get_object_prototype ctx l in + vobject { + ofields = Array.of_list (List.map snd sorted); + oproto = proto; + oextra = IntMap.empty; + oremoved = IntMap.empty; + } + +let encode_obj_s k l = + encode_obj k (List.map (fun (s,v) -> (hash_s s),v) l) + +(* Enum values *) + +let encode_enum_value path i vl pos = + venum_value { + eindex = i; + eargs = vl; + epath = path; + enpos = pos; + } + +let encode_enum i pos index pl = + let open MacroApi in + let key = match i with + | IExpr -> key_haxe_macro_ExprDef + | IBinop -> key_haxe_macro_Binop + | IUnop -> key_haxe_macro_Unop + | IConst -> key_haxe_macro_Constant + | ITParam -> key_haxe_macro_TypeParam + | ICType -> key_haxe_macro_ComplexType + | IField -> key_haxe_macro_FieldType + | IType -> key_haxe_macro_Type + | IFieldKind -> key_haxe_macro_FieldKind + | IMethodKind -> key_haxe_macro_MethodKind + | IVarAccess -> key_haxe_macro_VarAccess + | IAccess -> key_haxe_macro_Access + | IClassKind -> key_haxe_macro_ClassKind + | ITypedExpr -> key_haxe_macro_TypedExprDef + | ITConstant -> key_haxe_macro_TConstant + | IModuleType -> key_haxe_macro_ModuleType + | IFieldAccess -> key_haxe_macro_FieldAccess + | IAnonStatus -> key_haxe_macro_AnonStatus + | IImportMode -> key_haxe_macro_ImportMode + in + encode_enum_value key index (Array.of_list pl) pos + +(* Instances *) + +let create_instance_direct proto = + vinstance { + ifields = if Array.length proto.pinstance_fields = 0 then proto.pinstance_fields else Array.copy proto.pinstance_fields; + iproto = proto; + ikind = INormal; + } + +let create_instance ?(kind=INormal) path = + let proto = get_instance_prototype (get_ctx()) path null_pos in + { + ifields = if Array.length proto.pinstance_fields = 0 then proto.pinstance_fields else Array.copy proto.pinstance_fields; + iproto = proto; + ikind = kind; + } + +let encode_instance ?(kind=INormal) path = + vinstance (create_instance ~kind path) + +let encode_array_instance a = + VArray a + +let encode_vector_instance v = + VVector v + +let encode_array l = + encode_array_instance (EvalArray.create (Array.of_list l)) + +let encode_string s = + VString(Rope.of_string s,lazy s) + +let encode_rope s = + vstring s + +let encode_bytes s = + encode_instance key_haxe_io_Bytes ~kind:(IBytes s) + +let encode_string_map_direct h = + encode_instance key_haxe_ds_StringMap ~kind:(IStringMap h) + +let encode_string_map convert m = + let h = StringHashtbl.create 0 in + PMap.iter (fun key value -> StringHashtbl.add h (Rope.of_string key,lazy key) (convert value)) m; + encode_string_map_direct h + +let fake_proto path = + let proto = { + ppath = path; + pfields = [||]; + pnames = IntMap.empty; + pinstance_names = IntMap.empty; + pinstance_fields = [||]; + pparent = None; + pkind = PInstance; + pvalue = vnull; + } in + proto.pvalue <- vprototype proto; + proto + +let encode_unsafe o = + vinstance { + ifields = [||]; + iproto = fake_proto key_haxe_macro_Unsafe; + ikind = IRef (Obj.repr o); + } + +let encode_pos p = + vinstance { + ifields = [||]; + iproto = fake_proto key_haxe_macro_Position; + ikind = IPos p; + } + +let encode_lazytype t f = + vinstance { + ifields = [||]; + iproto = fake_proto key_haxe_macro_LazyType; + ikind = ILazyType(t,f); + } + +let encode_tdecl t = + vinstance { + ifields = [||]; + iproto = fake_proto key_haxe_macro_TypeDecl; + ikind = ITypeDecl t; + } + +let ref_proto = + let proto = { + ppath = key_haxe_macro_Ref; + pfields = [||]; + pnames = IntMap.empty; + pinstance_names = IntMap.add key_get 0 (IntMap.singleton key_toString 1); + pinstance_fields = [|vnull;vnull|]; + pparent = None; + pkind = PInstance; + pvalue = vnull; + } in + proto.pvalue <- vprototype proto; + proto + +let encode_ref v convert tostr = + vinstance { + ifields = [|vifun0 (fun _ -> convert v);vifun0 (fun _ -> encode_string (tostr()))|]; + iproto = ref_proto; + ikind = IRef (Obj.repr v); + } diff --git a/src/macro/eval/evalExceptions.ml b/src/macro/eval/evalExceptions.ml new file mode 100644 index 00000000000..813432f072c --- /dev/null +++ b/src/macro/eval/evalExceptions.ml @@ -0,0 +1,149 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open EvalContext +open EvalValue +open EvalPrinting +open EvalHash +open EvalField + +exception Break +exception Continue +exception Return of value + +let is v path = + path = key_Dynamic || match v with + | VInt32 _ -> path = key_Int || path = key_Float + | VFloat f -> path = key_Float || (path = key_Int && f = (float_of_int (int_of_float f)) && f <= 2147483647. && f >= -2147483648.) + | VTrue | VFalse -> path = key_Bool + | VPrototype {pkind = PClass _} -> path = key_Class + | VPrototype {pkind = PEnum _} -> path = key_Enum + | VEnumValue ve -> path = key_EnumValue || path = ve.epath + | VString _ -> path = key_String + | VArray _ -> path = key_Array + | VVector _ -> path = key_eval_Vector + | VInstance vi -> + let has_interface path' = + try begin match (get_static_prototype_raise (get_ctx()) path').pkind with + | PClass interfaces -> List.mem path interfaces + | _ -> false + end with Not_found -> + false + in + let rec loop proto = + if path = proto.ppath || has_interface proto.ppath then true + else begin match proto.pparent with + | Some proto -> loop proto + | None -> false + end + in + loop vi.iproto + | _ -> false + +let s_value_kind = function + | VNull -> "VNull" + | VTrue -> "VTrue" + | VFalse -> "VFalse" + | VInt32 _ -> "VInt32" + | VFloat _ -> "VFloat" + | VEnumValue _ -> "VEnumValue" + | VObject _ -> "VObject" + | VString _ -> "VString" + | VArray _ -> "VArray" + | VVector _ -> "VVector" + | VInstance _ -> "VInstance" + | VPrototype _ -> "VPrototype" + | VFunction _ -> "VFunction" + | VFieldClosure _ -> "VFieldClosure" + +let unexpected_value : 'a . value -> string -> 'a = fun v s -> + let str = Printf.sprintf "Unexpected value %s(%s), expected %s" (s_value_kind v) (value_string v) s in + exc_string str + +let invalid_call_arg_number i i2 = + exc_string (Printf.sprintf "Invalid number of call arguments: Expected %i, got %i" i i2) + +let format_pos p = + let error_printer file line = Printf.sprintf "%s:%d:" file line in + Lexer.get_error_pos error_printer p + +let uncaught_exception_string v p extra = + (Printf.sprintf "%s: Uncaught exception %s%s" (format_pos p) (value_string v) extra) + +let get_exc_error_message ctx v stack p = + let pl = List.map (fun env -> {pfile = rev_hash_s env.env_info.pfile;pmin = env.env_leave_pmin; pmax = env.env_leave_pmax}) stack in + let pl = List.filter (fun p -> p <> null_pos) pl in + match pl with + | [] -> + let extra = if ctx.record_stack then "" else "\nNo stack information available, consider compiling with -D eval-stack" in + uncaught_exception_string v p extra + | _ -> + let sstack = String.concat "\n" (List.map (fun p -> Printf.sprintf "%s: Called from here" (format_pos p)) pl) in + Printf.sprintf "%s: Uncaught exception %s\n%s" (format_pos p) (value_string v) sstack + +let build_exception_stack ctx environment_offset = + let eval = get_eval ctx in + let d = if not ctx.record_stack then [] else DynArray.to_list (DynArray.sub eval.environments environment_offset (eval.environment_offset - environment_offset)) in + ctx.exception_stack <- List.map (fun env -> + env.env_in_use <- false; + env.env_debug.timer(); + {pfile = rev_hash_s env.env_info.pfile;pmin = env.env_leave_pmin; pmax = env.env_leave_pmax},env.env_info.kind + ) d + +let catch_exceptions ctx ?(final=(fun() -> ())) f p = + let prev = !get_ctx_ref in + select ctx; + let eval = get_eval ctx in + let environment_offset = eval.environment_offset in + let r = try + let v = f() in + get_ctx_ref := prev; + final(); + Some v + with + | RunTimeException(v,stack,p') -> + build_exception_stack ctx environment_offset; + eval.environment_offset <- environment_offset; + if is v key_haxe_macro_Error then begin + let v1 = field v key_message in + let v2 = field v key_pos in + get_ctx_ref := prev; + final(); + match v1,v2 with + | VString(_,s),VInstance {ikind = IPos p} -> + raise (Error.Error (Error.Custom (Lazy.force s),p)) + | _ -> + Error.error "Something went wrong" null_pos + end else begin + (* Careful: We have to get the message before resetting the context because toString() might access it. *) + let msg = get_exc_error_message ctx v (match stack with [] -> [] | _ :: l -> l) (if p' = null_pos then p else p') in + get_ctx_ref := prev; + final(); + Error.error msg null_pos + end + | MacroApi.Abort -> + final(); + None + | exc -> + get_ctx_ref := prev; + final(); + raise exc + in + r \ No newline at end of file diff --git a/src/macro/eval/evalField.ml b/src/macro/eval/evalField.ml new file mode 100644 index 00000000000..67c9b681167 --- /dev/null +++ b/src/macro/eval/evalField.ml @@ -0,0 +1,69 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open EvalValue +open EvalContext +open EvalHash + +let no_field = + vnull + +let proto_field_direct proto name = + proto.pfields.(get_proto_field_index_raise proto name) + +let rec proto_field_raise proto name = + try proto_field_direct proto name + with Not_found -> match proto.pparent with + | Some proto -> proto_field_raise proto name + | _ -> raise Not_found + +let instance_field vi name = + vi.ifields.(get_instance_field_index_raise vi.iproto name) + +let object_field_raise o name = + try o.ofields.(get_instance_field_index_raise o.oproto name) + with Not_found -> IntMap.find name o.oextra + +let object_field o name = + try object_field_raise o name with Not_found -> vnull + +let field_raise v f = + match v with + | VObject o -> object_field_raise o f + | VInstance {ikind = IBytes s} when f = key_length -> vint (Bytes.length s) + | VPrototype proto -> proto_field_raise proto f + | VArray va -> + if f = key_length then vint (va.alength) + else proto_field_direct (get_instance_prototype_raise (get_ctx()) key_Array) f + | VVector vv -> + if f = key_length then vint (Array.length vv) + else proto_field_direct (get_instance_prototype_raise (get_ctx()) key_eval_Vector) f + | VString (_,s) -> + if f = key_length then vint (String.length (Lazy.force s)) + else proto_field_direct (get_ctx()).string_prototype f + | VInstance vi -> (try instance_field vi f with Not_found -> proto_field_raise vi.iproto f) + | _ -> raise Not_found + +let field v f = + try field_raise v f with Not_found -> no_field + +let dynamic_field v name = match field v name with + | VFunction(f,false) -> vfield_closure v f + | v -> v \ No newline at end of file diff --git a/src/macro/eval/evalHash.ml b/src/macro/eval/evalHash.ml new file mode 100644 index 00000000000..40e3c1a33d3 --- /dev/null +++ b/src/macro/eval/evalHash.ml @@ -0,0 +1,138 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +let reverse_map = Hashtbl.create 0 +let file_map = Hashtbl.create 0 + +let rev_hash i = Hashtbl.find reverse_map i + +let rev_hash_s i = Rope.to_string (rev_hash i) + +let hash f = + let i = Hashtbl.hash (Rope.to_string f) in + Hashtbl.replace reverse_map i f; + i + +let hash_s f = + let i = Hashtbl.hash f in + Hashtbl.replace reverse_map i (Rope.of_string f); + i + +let path_hash path = hash_s (Globals.s_type_path path) + +let file_hash file = + let unique_file = Path.unique_full_path file in + Hashtbl.replace file_map unique_file file; + hash_s unique_file + +let rev_file_hash i = + let s = rev_hash_s i in + try Hashtbl.find file_map s with Not_found -> s + +let key_length = hash_s "length" +let key_toString = hash_s "toString" +let key_OutsideBounds = hash_s "OutsideBounds" +let key_low = hash_s "low" +let key_high = hash_s "high" +let key_next = hash_s "next" +let key_hasNext = hash_s "hasNext" +let key___meta__ = hash_s "__meta__" +let key_get = hash_s "get" +let key_pos = hash_s "pos" +let key_len = hash_s "len" +let key_message = hash_s "message" +let key_Array = hash_s "Array" +let key_eval_Vector = hash_s "eval.Vector" +let key_String = hash_s "String" +let key_haxe_ds_StringMap = hash_s "haxe.ds.StringMap" +let key_haxe_ds_IntMap = hash_s "haxe.ds.IntMap" +let key_haxe_ds_ObjectMap = hash_s "haxe.ds.ObjectMap" +let key_haxe_macro_Position = hash_s "haxe.macro.Position" +let key_haxe_macro_LazyType = hash_s "haxe.macro.LazyType" +let key_haxe_macro_TypeDecl = hash_s "haxe.macro.TypeDecl" +let key_haxe_Utf8 = hash_s "haxe.Utf8" +let key_haxe_macro_Ref = hash_s "haxe.macro.Ref" +let key_haxe_io_Error = hash_s "haxe.io.Error" +let key_haxe_io_Bytes = hash_s "haxe.io.Bytes" +let key_Date = hash_s "Date" +let key_Dynamic = hash_s "Dynamic" +let key_ValueType = hash_s "ValueType" +let key_EReg = hash_s "EReg" +let key_haxe_io_BytesBuffer = hash_s "haxe.io.BytesBuffer" +let key_StringBuf = hash_s "StringBuf" +let key_haxe_macro_Error = hash_s "haxe.macro.Error" +let key_Int = hash_s "Int" +let key_Float = hash_s "Float" +let key_Bool = hash_s "Bool" +let key_Class = hash_s "Class" +let key_Enum = hash_s "Enum" +let key_EnumValue = hash_s "EnumValue" +let key_gid = hash_s "gid" +let key_uid = hash_s "uid" +let key_atime = hash_s "atime" +let key_mtime = hash_s "mtime" +let key_ctime = hash_s "ctime" +let key_dev = hash_s "dev" +let key_ino = hash_s "ino" +let key_nlink = hash_s "nlink" +let key_rdev = hash_s "rdev" +let key_size = hash_s "size" +let key_mode = hash_s "mode" +let key_haxe__Int64____Int64 = hash_s "haxe._Int64.___Int64" +let key_haxe_macro_Unsafe = hash_s "haxe.macro.Unsafe" +let key_sys_io__Process_NativeProcess = hash_s "sys.io._Process.NativeProcess" +let key_sys_io_FileOutput = hash_s "sys.io.FileOutput" +let key_sys_io_FileInput = hash_s "sys.io.FileInput" +let key_haxe_io_Eof = hash_s "haxe.io.Eof" +let key_haxe_macro_ExprDef = hash_s "haxe.macro.ExprDef" +let key_haxe_macro_Binop = hash_s "haxe.macro.Binop" +let key_haxe_macro_Unop = hash_s "haxe.macro.Unop" +let key_haxe_macro_Constant = hash_s "haxe.macro.Constant" +let key_haxe_macro_TypeParam = hash_s "haxe.macro.TypeParam" +let key_haxe_macro_ComplexType = hash_s "haxe.macro.ComplexType" +let key_haxe_macro_FieldType = hash_s "haxe.macro.FieldType" +let key_haxe_macro_Type = hash_s "haxe.macro.Type" +let key_haxe_macro_FieldKind = hash_s "haxe.macro.FieldKind" +let key_haxe_macro_MethodKind = hash_s "haxe.macro.MethodKind" +let key_haxe_macro_VarAccess = hash_s "haxe.macro.VarAccess" +let key_haxe_macro_Access = hash_s "haxe.macro.Access" +let key_haxe_macro_ClassKind = hash_s "haxe.macro.ClassKind" +let key_haxe_macro_TypedExprDef = hash_s "haxe.macro.TypedExprDef" +let key_haxe_macro_TConstant = hash_s "haxe.macro.TConstant" +let key_haxe_macro_ModuleType = hash_s "haxe.macro.ModuleType" +let key_haxe_macro_FieldAccess = hash_s "haxe.macro.FieldAccess" +let key_haxe_macro_AnonStatus = hash_s "haxe.macro.AnonStatus" +let key_haxe_macro_ImportMode = hash_s "haxe.macro.ImportMode" +let key_haxe_CallStack = hash_s "haxe.CallStack" +let key___init__ = hash_s "__init__" +let key_new = hash_s "new" +let key_questionmark = hash_s "?" +let key_haxe_StackItem = hash_s "haxe.StackItem" +let key_sys_net__Socket_NativeSocket = hash_s "sys.net._Socket.NativeSocket" +let key_ip = hash_s "ip" +let key_port = hash_s "port" +let key_sys_net_Socket = hash_s "sys.net.Socket" +let key_socket = hash_s "socket" +let key_read = hash_s "read" +let key_write = hash_s "write" +let key_others = hash_s "others" +let key_eval_vm_Thread = hash_s "eval.vm.Thread" +let key_haxe_zip_Compress = hash_s "haxe.zip.Compress" +let key_haxe_zip_Uncompress = hash_s "haxe.zip.Uncompress" +let key_done = hash_s "done" \ No newline at end of file diff --git a/src/macro/eval/evalJit.ml b/src/macro/eval/evalJit.ml new file mode 100644 index 00000000000..6dde4dd6928 --- /dev/null +++ b/src/macro/eval/evalJit.ml @@ -0,0 +1,850 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open Ast +open Type +open EvalValue +open EvalContext +open EvalHash +open EvalEmitter + +(* Helper *) + +let rope_path t = match follow t with + | TInst({cl_path=path},_) | TEnum({e_path=path},_) | TAbstract({a_path=path},_) -> Rope.of_string (s_type_path path) + | TDynamic _ -> Rope.of_string "Dynamic" + | TFun _ | TAnon _ | TMono _ | TType _ | TLazy _ -> assert false + +let eone = mk (TConst(TInt (Int32.one))) t_dynamic null_pos + +let eval_const = function + | TString s -> vstring (Rope.of_string s) + | TInt i32 -> vint32 i32 + | TFloat f -> vfloat (float_of_string f) + | TBool b -> vbool b + | TNull -> vnull + | TThis | TSuper -> assert false + +let is_int t = match follow t with + | TAbstract({a_path=[],"Int"},_) -> true + | _ -> false + +let get_binop_fun op p = match op with + | OpAdd -> op_add + | OpMult -> op_mult p + | OpDiv -> op_div p + | OpSub -> op_sub p + | OpEq -> op_eq + | OpNotEq -> op_not_eq + | OpGt -> op_gt + | OpGte -> op_gte + | OpLt -> op_lt + | OpLte -> op_lte + | OpAnd -> op_and p + | OpOr -> op_or p + | OpXor -> op_xor p + | OpShl -> op_shl p + | OpShr -> op_shr p + | OpUShr -> op_ushr p + | OpMod -> op_mod p + | OpAssign | OpBoolAnd | OpBoolOr | OpAssignOp _ | OpInterval | OpArrow -> assert false + +open EvalJitContext + +let rec op_assign ctx jit e1 e2 = match e1.eexpr with + | TLocal var -> + let exec = jit_expr jit false e2 in + if var.v_capture then emit_capture_write (get_capture_slot jit var.v_id) exec + else emit_local_write (get_slot jit var.v_id e1.epos) exec + | TField(e1,fa) -> + let name = hash_s (field_name fa) in + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + begin match fa with + | FStatic({cl_path=path},_) | FEnum({e_path=path},_) -> + let proto = get_static_prototype jit.ctx (path_hash path) e1.epos in + emit_proto_field_write proto (get_proto_field_index proto name) exec2 + | FInstance({cl_path=([],"Array")},_,{cf_name="length"}) -> + emit_array_length_write exec1 exec2 + | FInstance(c,_,_) when not c.cl_interface -> + let proto = get_instance_prototype jit.ctx (path_hash c.cl_path) e1.epos in + let i = get_instance_field_index proto name in + emit_instance_field_write exec1 i exec2 + | FAnon cf -> + begin match follow e1.etype with + | TAnon an -> + let l = PMap.foldi (fun k _ acc -> (hash_s k,()) :: acc) an.a_fields [] in + let proto,_ = ctx.get_object_prototype ctx l in + let i = get_instance_field_index proto name in + emit_anon_field_write exec1 proto i name exec2 + | _ -> + emit_field_write exec1 name exec2 + end + | _ -> + emit_field_write exec1 name exec2 + end + | TArray(ea1,ea2) -> + begin match (follow ea1.etype) with + | TInst({cl_path=(["eval"],"Vector")}, _) -> + begin match ea1.eexpr with + | TLocal var when not var.v_capture -> + let exec2 = jit_expr jit false ea2 in + let exec3 = jit_expr jit false e2 in + emit_vector_local_write (get_slot jit var.v_id ea1.epos) exec2 exec3 ea2.epos + | _ -> + let exec1 = jit_expr jit false ea1 in + let exec2 = jit_expr jit false ea2 in + let exec3 = jit_expr jit false e2 in + emit_vector_write exec1 exec2 exec3 ea2.epos + end + | _ -> + begin match ea1.eexpr with + | TLocal var when not var.v_capture -> + let exec2 = jit_expr jit false ea2 in + let exec3 = jit_expr jit false e2 in + emit_array_local_write (get_slot jit var.v_id ea1.epos) exec2 exec3 ea2.epos + | _ -> + let exec1 = jit_expr jit false ea1 in + let exec2 = jit_expr jit false ea2 in + let exec3 = jit_expr jit false e2 in + emit_array_write exec1 exec2 exec3 ea2.epos + end + end + + | _ -> + assert false + +and op_assign_op jit op e1 e2 prefix = match e1.eexpr with + | TLocal var -> + let exec = jit_expr jit false e2 in + if var.v_capture then emit_capture_read_write (get_capture_slot jit var.v_id) exec op prefix + else emit_local_read_write (get_slot jit var.v_id e1.epos) exec op prefix + | TField(e1,fa) -> + let name = hash_s (field_name fa) in + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + begin match fa with + | FStatic({cl_path=path},_) -> + let proto = get_static_prototype jit.ctx (path_hash path) e1.epos in + emit_proto_field_read_write proto (get_proto_field_index proto name) exec2 op prefix + | FInstance(c,_,_) when not c.cl_interface -> + let proto = get_instance_prototype jit.ctx (path_hash c.cl_path) e1.epos in + let i = get_instance_field_index proto name in + emit_instance_field_read_write exec1 i exec2 op prefix + | _ -> + emit_field_read_write exec1 name exec2 op prefix + end + | TArray(ea1,ea2) -> + begin match (follow ea1.etype) with + | TInst({cl_path=(["eval"],"Vector")}, _) -> + begin match ea1.eexpr with + | TLocal var when not var.v_capture -> + let exec2 = jit_expr jit false ea2 in + let exec3 = jit_expr jit false e2 in + emit_vector_local_read_write (get_slot jit var.v_id ea1.epos) exec2 exec3 op prefix ea2.epos + | _ -> + let exec1 = jit_expr jit false ea1 in + let exec2 = jit_expr jit false ea2 in + let exec3 = jit_expr jit false e2 in + emit_vector_read_write exec1 exec2 exec3 op prefix ea2.epos + end + | _ -> + begin match ea1.eexpr with + | TLocal var when not var.v_capture -> + let exec2 = jit_expr jit false ea2 in + let exec3 = jit_expr jit false e2 in + emit_array_local_read_write (get_slot jit var.v_id ea1.epos) exec2 exec3 op prefix ea2.epos + | _ -> + let exec1 = jit_expr jit false ea1 in + let exec2 = jit_expr jit false ea2 in + let exec3 = jit_expr jit false e2 in + emit_array_read_write exec1 exec2 exec3 op prefix ea2.epos + end + end + | _ -> + assert false + +and op_incr jit e1 prefix p = match e1.eexpr with + | TLocal var -> + begin match var.v_capture,prefix with + | true,true -> emit_capture_incr_prefix (get_capture_slot jit var.v_id) + | true,false -> emit_capture_incr_postfix (get_capture_slot jit var.v_id) + | false,true -> emit_local_incr_prefix (get_slot jit var.v_id e1.epos) + | false,false -> emit_local_incr_postfix (get_slot jit var.v_id e1.epos) + end + | _ -> + op_assign_op jit (get_binop_fun OpAdd p) e1 eone prefix + +and op_decr jit e1 prefix p = match e1.eexpr with + | TLocal var -> + begin match var.v_capture,prefix with + | true,true -> emit_capture_decr_prefix (get_capture_slot jit var.v_id) + | true,false -> emit_capture_decr_postfix (get_capture_slot jit var.v_id) + | false,true -> emit_local_decr_prefix (get_slot jit var.v_id e1.epos) + | false,false -> emit_local_decr_postfix (get_slot jit var.v_id e1.epos) + end + | _ -> + op_assign_op jit (get_binop_fun OpSub p) e1 eone prefix + +and unop jit op flag e1 p = + match op with + | Not -> + let exec = jit_expr jit false e1 in + emit_not exec + | Neg -> + let exec = jit_expr jit false e1 in + emit_neg exec p + | NegBits -> + let exec = jit_expr jit false e1 in + emit_op_sub p (fun _ -> vint32 (Int32.minus_one)) exec + | Increment -> + op_incr jit e1 (flag = Prefix) p + | Decrement -> + op_decr jit e1 (flag = Prefix) p + +(* + This is the main jit function. It turns expression [e] into a function, which can be + executed int an environment of type [EvalContext.env]. +*) +and jit_expr jit return e = + let ctx = jit.ctx in + let rec loop e = match e.eexpr with + (* objects and values *) + | TVar(var,eo) -> + let varacc = declare_local jit var in + let exec = match eo with + | None -> emit_null + | Some e -> jit_expr jit false e + in + begin match varacc with + | Local slot -> emit_local_declaration slot exec + | Env slot -> emit_capture_declaration slot exec + end + | TConst TThis -> + emit_local_read (get_slot jit 0 e.epos) + | TConst ct -> + emit_const (eval_const ct) + | TObjectDecl fl -> + let fl = List.map (fun (s,e) -> hash_s s,jit_expr jit false e) fl in + let proto,_ = ctx.get_object_prototype ctx fl in + let fl = List.map (fun (s,exec) -> get_instance_field_index proto s,exec) fl in + let fa = Array.of_list fl in + emit_object_declaration proto fa + | TArrayDecl el -> + let execs = List.map (jit_expr jit false) el in + let execs = Array.of_list execs in + emit_array_declaration execs + | TTypeExpr mt -> + let key = path_hash (t_infos mt).mt_path in + let proto = get_static_prototype_as_value jit.ctx key e.epos in + emit_type_expr proto + | TFunction tf -> + let jit_closure = EvalJitContext.create ctx in + jit_closure.captures <- jit.captures; + jit_closure.capture_infos <- jit.capture_infos; + jit.num_closures <- jit.num_closures + 1; + let exec = jit_tfunction jit_closure true e.epos tf in + let num_captures = Hashtbl.length jit.captures in + let hasret = jit_closure.has_nonfinal_return in + let get_env = get_env jit_closure false (file_hash tf.tf_expr.epos.pfile) (EKLocalFunction jit.num_closures) in + let num_args = List.length tf.tf_args in + emit_closure ctx num_captures num_args get_env hasret exec + (* branching *) + | TIf(e1,e2,eo) -> + let exec_cond = jit_expr jit false e1 in + let exec_then = jit_expr jit return e2 in + let exec_else = match eo with + | None -> emit_null + | Some e -> jit_expr jit return e + in + emit_if exec_cond exec_then exec_else + | TSwitch(e1,cases,def) when is_int e1.etype -> + let exec = jit_expr jit false e1 in + let h = ref IntMap.empty in + let max = ref 0 in + let shift = ref 0 in + List.iter (fun (el,e) -> + push_scope jit e.epos; + let exec = jit_expr jit return e in + List.iter (fun e -> match e.eexpr with + | TConst (TInt i32) -> + let i = Int32.to_int i32 in + h := IntMap.add i exec !h; + if i > !max then max := i + else if i < !shift then shift := i + | _ -> assert false + ) el; + pop_scope jit; + ) cases; + let exec_def = match def with + | None -> emit_null + | Some e -> + push_scope jit e.epos; + let exec = jit_expr jit return e in + pop_scope jit; + exec + in + let l = !max - !shift + 1 in + if l < 256 then begin + let cases = Array.init l (fun i -> try IntMap.find (i + !shift) !h with Not_found -> exec_def) in + if !shift = 0 then begin match (Texpr.skip e1).eexpr with + | TCall({eexpr = TField(_,FStatic({cl_path=[],"Type"},{cf_name="enumIndex"}))},[e1]) -> + let exec = jit_expr jit false e1 in + emit_enum_switch_array exec cases exec_def e1.epos + | _ -> + emit_int_switch_array exec cases exec_def e1.epos + end else + emit_int_switch_array_shift (- !shift) exec cases exec_def e1.epos + end else + emit_int_switch_map exec !h exec_def e1.epos + | TSwitch(e1,cases,def) -> + let exec = jit_expr jit false e1 in + let execs = DynArray.create () in + let constants = DynArray.create () in + let patterns = DynArray.create () in + let is_complex = ref false in + (* This is slightly insane... *) + List.iter (fun (el,e) -> + push_scope jit e.epos; + begin try + if !is_complex then raise Exit; + let el = List.map (fun e -> match e.eexpr with + | TConst ct -> eval_const ct + | _ -> raise Exit + ) el in + DynArray.add constants el + with Exit -> + is_complex := true; + let el = List.map (jit_expr jit false) el in + DynArray.add patterns el + end; + DynArray.add execs (jit_expr jit return e); + pop_scope jit; + ) cases; + let exec_def = match def with + | None -> + emit_null + | Some e -> + push_scope jit e.epos; + let exec = jit_expr jit return e in + pop_scope jit; + exec + in + if !is_complex then begin + let l = DynArray.length constants in + let all_patterns = Array.init (l + DynArray.length patterns) (fun i -> + if i >= l then DynArray.get patterns (i - l) else (List.map (fun ct -> fun _ -> ct) (DynArray.get constants i)) + ) in + emit_switch exec (DynArray.to_array execs) all_patterns exec_def + end else begin + emit_constant_switch exec (DynArray.to_array execs) (DynArray.to_array constants) exec_def + end + | TWhile({eexpr = TParenthesis e1},e2,flag) -> + loop {e with eexpr = TWhile(e1,e2,flag)} + | TWhile({eexpr = TBinop(OpLt,{eexpr = TLocal v;epos=pv},eto)},e2,NormalWhile) when (Meta.has Meta.ForLoopVariable v.v_meta) -> + let has_break = ref false in + let has_continue = ref false in + let rec loop e = match e.eexpr with + | TUnop(Increment,_,({eexpr = TLocal v'} as e1)) when v == v' -> e1 + | TWhile _ | TFor _ -> e + | TBreak -> has_break := true; e + | TContinue -> has_continue := true; e + | _ -> Type.map_expr loop e + in + let e2 = loop e2 in + let slot = get_slot jit v.v_id pv in + let exec1 = jit_expr jit false eto in + let exec2 = jit_expr jit false e2 in + begin match !has_break,!has_continue with + | false,false -> emit_int_iterator slot exec1 exec2 + | true,false -> emit_int_iterator_break slot exec1 exec2 + | false,true -> emit_int_iterator_continue slot exec1 exec2 + | true,true -> emit_int_iterator_break_continue slot exec1 exec2 + end + | TWhile(e1,e2,flag) -> + let has_break = ref false in + let has_continue = ref false in + let rec loop e = match e.eexpr with + | TContinue -> has_continue := true; if !has_break then raise Exit + | TBreak -> has_break := true; if !has_continue then raise Exit + | TFunction _ | TWhile _ | TFor _ -> () + | _ -> Type.iter loop e + in + (try loop e2 with Exit -> ()); + begin match e1.eexpr with + | TBinop(OpGte,e1,{eexpr = TConst (TFloat s)}) when not !has_break && not !has_continue && flag = NormalWhile -> + let f = float_of_string s in + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + emit_while_gte exec1 f exec2 + | _ -> + let exec_cond = jit_expr jit false e1 in + let exec_body = jit_expr jit false e2 in + (* This is a bit moronic, but it does avoid run-time branching and setting up some exception + handlers for break/continue, so it might be worth it... *) + begin match flag,!has_break,!has_continue with + | NormalWhile,false,false -> emit_while exec_cond exec_body + | NormalWhile,true,false -> emit_while_break exec_cond exec_body + | NormalWhile,false,true -> emit_while_continue exec_cond exec_body + | NormalWhile,true,true -> emit_while_break_continue exec_cond exec_body + | DoWhile,false,false -> emit_do_while exec_cond exec_body + | DoWhile,true,false -> emit_do_while_break exec_cond exec_body + | DoWhile,false,true -> emit_do_while_continue exec_cond exec_body + | DoWhile,true,true -> emit_do_while_break_continue exec_cond exec_body + end + end + | TTry(e1,catches) -> + let exec = jit_expr jit return e1 in + let catches = List.map (fun (var,e) -> + push_scope jit e.epos; + let varacc = declare_local jit var in + let exec = jit_expr jit return e in + pop_scope jit; + let key = hash (rope_path var.v_type) in + exec,key,varacc + ) catches in + emit_try exec catches + (* control flow *) + | TBlock [] -> + emit_null + | TBlock el when ctx.debug.support_debugger -> + let e1,el = match List.rev el with + | e1 :: el -> e1,List.rev el + | [] -> assert false + in + push_scope jit e.epos; + let execs = List.map (jit_expr jit false) el in + let exec1 = jit_expr jit return e1 in + pop_scope jit; + emit_block (Array.of_list (execs @ [exec1])) + | TBlock [e1] -> + loop e1 + | TBlock [e1;e2] -> + push_scope jit e.epos; + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit return e2 in + pop_scope jit; + emit_block2 exec1 exec2 + | TBlock [e1;e2;e3] -> + push_scope jit e.epos; + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + let exec3 = jit_expr jit return e3 in + pop_scope jit; + emit_block3 exec1 exec2 exec3 + | TBlock [e1;e2;e3;e4] -> + push_scope jit e.epos; + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + let exec3 = jit_expr jit false e3 in + let exec4 = jit_expr jit return e4 in + pop_scope jit; + emit_block4 exec1 exec2 exec3 exec4 + | TBlock [e1;e2;e3;e4;e5] -> + push_scope jit e.epos; + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + let exec3 = jit_expr jit false e3 in + let exec4 = jit_expr jit false e4 in + let exec5 = jit_expr jit return e5 in + pop_scope jit; + emit_block5 exec1 exec2 exec3 exec4 exec5 + | TBlock el -> + let d = DynArray.create () in + let add = DynArray.add d in + let rec loop el = match el with + | e1 :: e2 :: e3 :: e4 :: e5 :: el -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + let exec3 = jit_expr jit false e3 in + let exec4 = jit_expr jit false e4 in + let exec5 = jit_expr jit (return && el = []) e5 in + add (emit_block5 exec1 exec2 exec3 exec4 exec5); + loop el + | e1 :: e2 :: e3 :: e4 :: el -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + let exec3 = jit_expr jit false e3 in + let exec4 = jit_expr jit (return && el = []) e4 in + add (emit_block4 exec1 exec2 exec3 exec4); + loop el + | e1 :: e2 :: e3 :: el -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + let exec3 = jit_expr jit (return && el = []) e3 in + add (emit_block3 exec1 exec2 exec3); + loop el + | e1 :: e2 :: el -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit (return && el = []) e2 in + add (emit_block2 exec1 exec2); + loop el + | [e1] -> + let exec1 = jit_expr jit return e1 in + add (emit_block1 exec1); + | [] -> + () + in + push_scope jit e.epos; + loop el; + pop_scope jit; + emit_block (DynArray.to_array d) + | TReturn None -> + if return then emit_null + else begin + jit.has_nonfinal_return <- true; + emit_return_null + end + | TReturn (Some e1) -> + let exec = jit_expr jit false e1 in + if return then emit_value exec + else begin + jit.has_nonfinal_return <- true; + emit_return_value exec + end + | TBreak -> + emit_break + | TContinue -> + emit_continue + | TThrow e1 -> + let exec = jit_expr jit false e1 in + emit_throw exec e.epos + | TCast(e1,Some mt) -> + let exec = jit_expr jit false e1 in + let t = type_of_module_type mt in + emit_safe_cast exec (hash (rope_path t)) e.epos + (* calls *) + | TCall(e1,el) -> + begin match e1.eexpr with + | TField({eexpr = TConst TSuper;epos=pv},FInstance(c,_,cf)) -> + let proto = get_instance_prototype ctx (path_hash c.cl_path) e1.epos in + let name = hash_s cf.cf_name in + let i = get_proto_field_index proto name in + let slot = get_slot jit 0 pv in + let execs = List.map (jit_expr jit false) el in + emit_super_field_call slot proto i execs e.epos + | TField(ef,fa) -> + let name = hash_s (field_name fa) in + let execs = List.map (jit_expr jit false) el in + let is_overridden c s_name = + try + Hashtbl.find ctx.overrides (c.cl_path,s_name) + with Not_found -> + false + in + let is_proper_method cf = match cf.cf_kind with + | Method MethDynamic -> false + | Method _ -> true + | Var _ -> false + in + let instance_call c = + let exec = jit_expr jit false ef in + let proto = get_instance_prototype ctx (path_hash c.cl_path) ef.epos in + let i = get_proto_field_index proto name in + emit_proto_field_call proto i (exec :: execs) e.epos + in + let default () = + let exec = jit_expr jit false ef in + emit_method_call exec name execs e.epos + in + begin match fa with + | FStatic({cl_path=[],"Type"},{cf_name="enumIndex"}) -> + begin match execs with + | [exec] -> emit_enum_index exec + | _ -> assert false + end + | FStatic({cl_path=[],"StringTools"},{cf_name="fastCodeAt"}) -> + begin match execs with + | [exec1;exec2] -> emit_string_cca exec1 exec2 e.epos + | _ -> assert false + end + | FEnum({e_path=path},ef) -> + let key = path_hash path in + let pos = Some ef.ef_pos in + begin match execs with + | [] -> emit_enum_construction0 key ef.ef_index pos + | [exec1] -> emit_enum_construction1 key ef.ef_index exec1 pos + | [exec1;exec2] -> emit_enum_construction2 key ef.ef_index exec1 exec2 pos + | [exec1;exec2;exec3] -> emit_enum_construction3 key ef.ef_index exec1 exec2 exec3 pos + | [exec1;exec2;exec3;exec4] -> emit_enum_construction4 key ef.ef_index exec1 exec2 exec3 exec4 pos + | [exec1;exec2;exec3;exec4;exec5] -> emit_enum_construction5 key ef.ef_index exec1 exec2 exec3 exec4 exec5 pos + | _ -> emit_enum_construction key ef.ef_index (Array.of_list execs) pos + end + | FStatic({cl_path=path},cf) when is_proper_method cf -> + let proto = get_static_prototype ctx (path_hash path) ef.epos in + let i = get_proto_field_index proto name in + emit_proto_field_call proto i execs e.epos + | FInstance(c,_,cf) when is_proper_method cf -> + if is_overridden c cf.cf_name then + default() + else if not c.cl_interface then + instance_call c + else if c.cl_implements = [] && c.cl_super = None then begin match c.cl_descendants with + | [c'] when not c'.cl_interface && not (is_overridden c' cf.cf_name) -> + instance_call c' + | _ -> + default() + end else + default() + | _ -> + let exec = jit_expr jit false ef in + emit_field_call exec name execs e.epos + end + | TConst TSuper -> + begin match follow e1.etype with + | TInst(c,_) -> + let key = (path_hash c.cl_path) in + let execs = List.map (jit_expr jit false) el in + let fnew = get_instance_constructor jit.ctx key e1.epos in + emit_super_call fnew execs e.epos + | _ -> assert false + end + | _ -> + match e1.eexpr,el with + | TLocal({v_name = "$__mk_pos__"}),[file;min;max] -> + let exec1 = jit_expr jit false file in + let exec2 = jit_expr jit false min in + let exec3 = jit_expr jit false max in + emit_mk_pos exec1 exec2 exec3 + | TLocal({v_name = "$__delayed_call__"}),[{eexpr = TConst(TInt i)}] -> + let f = ctx.curapi.MacroApi.delayed_macro (Int32.to_int i) in + (fun env -> + let f = f() in + f() + ) + | _ -> + let exec = jit_expr jit false e1 in + let execs = List.map (jit_expr jit false) el in + begin match execs with + | [] -> emit_call0 exec e.epos + | [exec1] -> emit_call1 exec exec1 e.epos + | [exec1;exec2] -> emit_call2 exec exec1 exec2 e.epos + | [exec1;exec2;exec3] -> emit_call3 exec exec1 exec2 exec3 e.epos + | [exec1;exec2;exec3;exec4] -> emit_call4 exec exec1 exec2 exec3 exec4 e.epos + | _ -> emit_call exec execs e.epos + end + end + | TNew({cl_path=[],"Array"},_,_) -> + emit_new_array + | TNew({cl_path=["eval"],"Vector"},_,[e1]) -> + begin match e1.eexpr with + | TConst (TInt i32) -> + emit_new_vector_int (Int32.to_int i32) + | _ -> + let exec1 = jit_expr jit false e1 in + emit_new_vector exec1 + end + | TNew(c,_,el) -> + let execs = List.map (jit_expr jit false) el in + let key = path_hash c.cl_path in + begin try + let f = get_special_instance_constructor_raise ctx key in + emit_special_instance f execs + with Not_found -> + let fnew = get_instance_constructor jit.ctx key e.epos in + let proto = get_instance_prototype jit.ctx key e.epos in + emit_constructor_call proto fnew execs e.epos + end + (* read *) + | TLocal var -> + if var.v_capture then emit_capture_read (get_capture_slot jit var.v_id) + else emit_local_read (get_slot jit var.v_id e.epos) + | TField(e1,fa) -> + let name = hash_s (field_name fa) in + begin match fa with + | FInstance({cl_path=([],"Array")},_,{cf_name="length"}) -> emit_array_length_read (jit_expr jit false e1) + | FInstance({cl_path=(["eval"],"Vector")},_,{cf_name="length"}) -> emit_vector_length_read (jit_expr jit false e1) + | FInstance({cl_path=(["haxe";"io"],"Bytes")},_,{cf_name="length"}) -> emit_bytes_length_read (jit_expr jit false e1) + | FStatic({cl_path=path},_) | FEnum({e_path=path},_) -> + let proto = get_static_prototype ctx (path_hash path) e1.epos in + emit_proto_field_read proto (get_proto_field_index proto name) + | FInstance(c,_,_) when not c.cl_interface -> + let proto = get_instance_prototype ctx (path_hash c.cl_path) e1.epos in + let i = get_instance_field_index proto name in + begin match e1.eexpr with + | TLocal var when not var.v_capture -> emit_instance_local_field_read (get_slot jit var.v_id e1.epos) i + | _ -> emit_instance_field_read (jit_expr jit false e1) i + end + | FAnon _ -> + begin match follow e1.etype with + | TAnon an -> + let l = PMap.foldi (fun k _ acc -> (hash_s k,()) :: acc) an.a_fields [] in + let proto,_ = ctx.get_object_prototype ctx l in + let i = get_instance_field_index proto name in + begin match e1.eexpr with + | TLocal var when not var.v_capture -> emit_anon_local_field_read (get_slot jit var.v_id e1.epos) proto i name e1.epos + | _ -> emit_anon_field_read (jit_expr jit false e1) proto i name e1.epos + end + | _ -> + emit_field_read (jit_expr jit false e1) name e1.epos + end + | FClosure _ | FDynamic _ -> + let exec = jit_expr jit false e1 in + emit_field_closure exec name + | _ -> + let exec = jit_expr jit false e1 in + emit_field_read exec name e1.epos + end + | TArray(e1,e2) -> + begin match (follow e1.etype) with + | TInst({cl_path=(["eval"],"Vector")}, _) -> + begin match e1.eexpr with + | TLocal var when not var.v_capture -> + emit_vector_local_read (get_slot jit var.v_id e1.epos) (jit_expr jit false e2) + | _ -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + emit_vector_read exec1 exec2 + end + | _ -> + begin match e1.eexpr with + | TLocal var when not var.v_capture -> + emit_array_local_read (get_slot jit var.v_id e1.epos) (jit_expr jit false e2) + | _ -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + emit_array_read exec1 exec2 + end + end + | TEnumParameter(e1,_,i) -> + let exec = jit_expr jit false e1 in + emit_enum_parameter_read exec i + (* ops *) + | TBinop(OpEq,e1,{eexpr = TConst TNull}) | TBinop(OpEq,{eexpr = TConst TNull},e1) -> + let exec = jit_expr jit false e1 in + emit_eq_null exec + | TBinop(OpNotEq,e1,{eexpr = TConst TNull}) | TBinop(OpNotEq,{eexpr = TConst TNull},e1) -> + let exec = jit_expr jit false e1 in + emit_not_eq_null exec + | TBinop(op,e1,e2) -> + begin match op with + | OpAssign -> + op_assign ctx jit e1 e2 + | OpAssignOp op -> + let f = get_binop_fun op e.epos in + op_assign_op jit f e1 e2 true + | OpBoolAnd -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + emit_bool_and exec1 exec2 + | OpBoolOr -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + emit_bool_or exec1 exec2 + | _ -> + let exec1 = jit_expr jit false e1 in + let exec2 = jit_expr jit false e2 in + begin match op with + | OpAdd -> emit_op_add exec1 exec2 + | OpMult -> emit_op_mult e.epos exec1 exec2 + | OpDiv -> emit_op_div e.epos exec1 exec2 + | OpSub -> emit_op_sub e.epos exec1 exec2 + | OpEq -> emit_op_eq exec1 exec2 + | OpNotEq -> emit_op_not_eq exec1 exec2 + | OpGt -> emit_op_gt exec1 exec2 + | OpGte -> emit_op_gte exec1 exec2 + | OpLt -> emit_op_lt exec1 exec2 + | OpLte -> emit_op_lte exec1 exec2 + | OpAnd -> emit_op_and e.epos exec1 exec2 + | OpOr -> emit_op_or e.epos exec1 exec2 + | OpXor -> emit_op_xor e.epos exec1 exec2 + | OpShl -> emit_op_shl e.epos exec1 exec2 + | OpShr -> emit_op_shr e.epos exec1 exec2 + | OpUShr -> emit_op_ushr e.epos exec1 exec2 + | OpMod -> emit_op_mod e.epos exec1 exec2 + | _ -> assert false + end + end + | TUnop(op,flag,v1) -> + unop jit op flag v1 e.epos + (* rewrites/skips *) + | TFor(v,e1,e2) -> + loop (Codegen.for_remap (ctx.curapi.MacroApi.get_com()) v e1 e2 e.epos) + | TParenthesis e1 | TMeta(_,e1) | TCast(e1,None) -> + loop e1 + in + let f = loop e in + if ctx.debug.support_debugger then begin match e.eexpr with + | TConst _ | TLocal _ | TTypeExpr _ | TBlock _ | TField _ -> f + | _ -> EvalDebug.debug_loop jit e f + end else + f + +and jit_tfunction jit static pos tf = + let ctx = jit.ctx in + push_scope jit pos; + (* Declare `this` (if not static) and function arguments as local variables. *) + if not static then ignore(declare_local_this jit); + let varaccs = ExtList.List.filter_map (fun (var,_) -> + let slot = add_local jit var in + if var.v_capture then Some (slot,add_capture jit var) else None + ) tf.tf_args in + (* Add conditionals for default values. *) + let e = List.fold_left (fun e (v,cto) -> match cto with + | None -> e + | Some ct -> concat (Codegen.set_default (ctx.curapi.MacroApi.get_com()) v ct e.epos) e + ) tf.tf_expr tf.tf_args in + (* Jit the function expression. *) + let exec = jit_expr jit true e in + (* Deal with captured arguments, if necessary. *) + let exec = match varaccs with + | [] -> exec + | _ -> handle_capture_arguments exec varaccs + in + pop_scope jit; + exec + +and get_env jit static file info = + let ctx = jit.ctx in + let num_locals = jit.max_num_locals in + let num_captures = Hashtbl.length jit.captures in + let info = create_env_info static file info jit.capture_infos in + if ctx.record_stack || num_captures > 0 then begin + match info.kind with + | EKLocalFunction _ -> get_closure_env ctx info num_locals num_captures + | _ -> get_normal_env ctx info num_locals num_captures + end else begin + let default_env = create_default_environment ctx info num_locals in + match info.kind with + | EKLocalFunction _ -> get_closure_env_opt ctx default_env info num_locals num_captures + | _ -> get_normal_env_opt ctx default_env info num_locals num_captures + end + +(* Creates a [EvalValue.vfunc] of function [tf], which can be [static] or not. *) +let jit_tfunction ctx key_type key_field tf static pos = + let t = Common.timer [(if ctx.is_macro then "macro" else "interp");"jit"] in + (* Create a new JitContext with an initial scope *) + let jit = EvalJitContext.create ctx in + let exec = jit_tfunction jit static pos tf in + (* Create the [vfunc] instance depending on the number of arguments. *) + let hasret = jit.has_nonfinal_return in + let get_env = get_env jit static (file_hash tf.tf_expr.epos.pfile) (EKMethod(key_type,key_field)) in + let num_args = List.length tf.tf_args + (if not static then 1 else 0) in + let f = create_function ctx num_args get_env hasret empty_array exec in + t(); + f + +(* JITs expression [e] to a function. This is used for expressions that are not in a method. *) +let jit_expr ctx e = + let t = Common.timer [(if ctx.is_macro then "macro" else "interp");"jit"] in + let jit = EvalJitContext.create ctx in + let f = jit_expr jit false (mk_block e) in + t(); + jit,f \ No newline at end of file diff --git a/src/macro/eval/evalJitContext.ml b/src/macro/eval/evalJitContext.ml new file mode 100644 index 00000000000..522f2ff0d07 --- /dev/null +++ b/src/macro/eval/evalJitContext.ml @@ -0,0 +1,144 @@ +open Type +open EvalContext +open EvalEmitter + +(* + JitContext keeps track of allocated local variables and closures. Scopes can be pushed + and popped and influence the "slots" of variables. It also manages the maximum number + of locals allocated at the same time, which the run-time can use to allocate a fixed + array. +*) + +type t = { + ctx : context; + (* The scope stack. *) + mutable scopes : scope list; + (* The captured variables declared in this context. Maps variable IDs to capture slots. *) + mutable captures : (int,int) Hashtbl.t; + (* The current number of locals. *) + mutable num_locals : int; + (* The maximum number of locals. *) + mutable max_num_locals : int; + (* The number of closures in this context.*) + mutable num_closures : int; + (* Whether or not this function has a return that's not at the end of control flow. *) + mutable has_nonfinal_return : bool; + (* The name of capture variables. Maps local slots to variable names. Only filled in debug mode. *) + mutable capture_infos : (int,var_info) Hashtbl.t; +} + +(* Creates a new context *) +let create ctx = { + ctx = ctx; + scopes = []; + captures = Hashtbl.create 0; + num_locals = 0; + max_num_locals = 0; + num_closures = 0; + has_nonfinal_return = false; + capture_infos = Hashtbl.create 0; +} + +(* Returns the number of locals in [scope]. *) +let num_locals scope = + Hashtbl.length scope.locals + +(* Pushes a new scope onto context [jit]. *) +let push_scope jit pos = + let scope = { + local_offset = jit.num_locals; + locals = Hashtbl.create 0; + local_infos = Hashtbl.create 0; + local_ids = Hashtbl.create 0; + pos = pos; + } in + jit.scopes <- scope :: jit.scopes + +(* Pops the top scope from context [jit] .*) +let pop_scope jit = match jit.scopes with + | scope :: tl -> + jit.scopes <- tl; + jit.num_locals <- jit.num_locals - (num_locals scope); + | [] -> + assert false + +(* Increases number of locals and updates maximum number of locals if necessary *) +let increase_num_locals jit = + jit.num_locals <- jit.num_locals + 1; + if jit.num_locals > jit.max_num_locals then jit.max_num_locals <- jit.num_locals + +(* Adds capture variable [var] to context [jit]. *) +let add_capture jit var = + let i = Hashtbl.length jit.captures in + Hashtbl.add jit.captures var.v_id i; + if jit.ctx.debug.support_debugger then begin + Hashtbl.replace jit.capture_infos i var.v_name + end; + i + +(* Adds variable [var] to the current top scope of context [jit]. *) +let add_local jit var = match jit.scopes with + | [] -> assert false + | scope :: _ -> + let i = Hashtbl.length scope.locals in + Hashtbl.add scope.locals var.v_id i; + increase_num_locals jit; + let slot = scope.local_offset + i in + if jit.ctx.debug.support_debugger then begin + Hashtbl.replace scope.local_ids var.v_name var.v_id; + Hashtbl.replace scope.local_infos i var.v_name + end; + slot + +(* + Declares variable [var] in context [jit]. If the variable is captured, it is added to + the capture hash table. Otherwise it is added to the local hash table of the top scope. + + Returns either [Env slot] if the variable is captured or [Local slot] otherwise. +*) +let declare_local jit var = + if var.v_capture then Env (add_capture jit var) + else Local (add_local jit var) + +(* + Declares function argument [var] in context [jit]. + + All function arguments are added as local variables. If the variable is captured, it + is also added as a capture variable. This is handled by [EvalEmitter.handle_capture_arguments]. +*) +let declare_arg jit var = + let varacc = add_local jit var in + if var.v_capture then add_capture jit var,Some varacc else varacc,None + +(* Declares a variable for `this` in context [jit]. *) +let declare_local_this jit = match jit.scopes with + | [] -> assert false + | scope :: _ -> + let i = Hashtbl.length scope.locals in + Hashtbl.add scope.locals 0 i; + increase_num_locals jit; + if jit.ctx.debug.support_debugger then begin + Hashtbl.replace scope.local_ids "this" 0; + Hashtbl.replace scope.local_infos 0 "this" + end; + Local i + +(* Gets the slot of variable id [vid] in context [jit]. *) +let get_slot_raise jit vid = + let rec loop scopes = match scopes with + | [] -> raise Not_found + | scope :: scopes -> + try + scope.local_offset + Hashtbl.find scope.locals vid + with Not_found -> + loop scopes + in + loop jit.scopes + +let get_slot jit vid p = + try get_slot_raise jit vid + with Not_found -> throw_string "Unbound variable" p + +(* Gets the slot of captured variable id [vid] in context [jit]. *) +let get_capture_slot jit vid = + Hashtbl.find jit.captures vid \ No newline at end of file diff --git a/src/macro/eval/evalMain.ml b/src/macro/eval/evalMain.ml new file mode 100644 index 00000000000..124dd3fdbc0 --- /dev/null +++ b/src/macro/eval/evalMain.ml @@ -0,0 +1,427 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open Ast +open Type +open Common +open EvalValue +open EvalContext +open EvalPrototype +open EvalExceptions +open EvalJit +open EvalJitContext +open EvalPrinting +open EvalMisc +open EvalHash +open EvalEncode +open EvalField +open MacroApi + +(* Create *) + +let sid = ref (-1) + +let stdlib = ref None +let debug = ref None + +let create com api is_macro = + let t = Common.timer [(if is_macro then "macro" else "interp");"create"] in + incr sid; + let builtins = match !stdlib with + | None -> + let builtins = { + static_builtins = IntMap.empty; + instance_builtins = IntMap.empty; + constructor_builtins = Hashtbl.create 0; + empty_constructor_builtins = Hashtbl.create 0; + } in + EvalStdLib.init_standard_library builtins; + stdlib := Some builtins; + builtins + | Some (builtins) -> + builtins + in + let debug = match !debug with + | None -> + let support_debugger = Common.defined com Define.EvalDebugger in + let socket = + try + if not support_debugger then raise Exit; + let fail msg = + print_endline msg; + raise Exit + in + let s = Common.defined_value com Define.EvalDebugger in + if s = "1" then raise Exit; + let host,port = try ExtString.String.split s ":" with _ -> fail "Invalid host format, expected host:port" in + let host = try Unix.inet_addr_of_string host with exc -> fail (Printexc.to_string exc) in + let port = try int_of_string port with _ -> fail "Invalid port, expected int" in + let socket = try (Unix.socket Unix.PF_INET Unix.SOCK_STREAM) 0 with exc -> fail (Printexc.to_string exc) in + Unix.connect socket (Unix.ADDR_INET (host,port)); + Some {addr = host; port = port; socket = Some socket} + with _ -> + None + in + let debug' = { + debug = com.Common.debug || support_debugger; + breakpoints = Hashtbl.create 0; + support_debugger = support_debugger; + debug_state = DbgStart; + breakpoint = EvalDebugMisc.make_breakpoint 0 0 BPDisabled BPAny; + caught_types = Hashtbl.create 0; + environment_offset_delta = 0; + debug_socket = socket; + } in + debug := Some debug'; + debug' + | Some debug -> + debug + in + let detail_times = Common.defined com Define.EvalTimes in + let record_stack = debug.support_debugger || detail_times || Common.defined com Define.EvalStack in + let evals = DynArray.create () in + let eval = { + environments = DynArray.make 32; + environment_offset = 0; + } in + DynArray.add evals eval; + let rec ctx = { + ctx_id = !sid; + is_macro = is_macro; + debug = debug; + record_stack = record_stack; + detail_times = detail_times; + curapi = api; + builtins = builtins; + type_cache = IntMap.empty; + overrides = Hashtbl.create 0; + had_error = false; + (* prototypes *) + string_prototype = fake_proto key_String; + static_prototypes = IntMap.empty; + instance_prototypes = IntMap.empty; + constructors = IntMap.empty; + get_object_prototype = get_object_prototype; + (* eval *) + eval = eval; + exception_stack = []; + } in + t(); + ctx + +(* API for macroContext.ml *) + +let eval_delayed ctx e = + let jit,f = jit_expr ctx e in + let info = create_env_info true (file_hash e.epos.pfile) EKDelayed jit.capture_infos in + fun () -> + let env = push_environment ctx info jit.max_num_locals (Hashtbl.length jit.captures) in + match catch_exceptions ctx (fun () -> Std.finally (fun _ -> pop_environment ctx env) f env) e.epos with + | Some v -> v + | None -> vnull + +let call_path ctx path f vl api = + if ctx.had_error then + None + else begin + let old = ctx.curapi in + ctx.curapi <- api; + let path = match List.rev path with + | [] -> assert false + | name :: path -> List.rev path,name + in + catch_exceptions ctx ~final:(fun () -> ctx.curapi <- old) (fun () -> + let vtype = get_static_prototype_as_value ctx (path_hash path) api.pos in + let vfield = field vtype (hash_s f) in + call_value_on vtype vfield vl + ) api.pos + end + +let value_signature v = + let buf = Buffer.create 0 in + let add s = Buffer.add_string buf s in + let addc c = Buffer.add_char buf c in + let scache = Hashtbl.create 0 in + let adds s = + try + let i = Hashtbl.find scache s in + addc 'R'; + add (string_of_int i) + with Not_found -> + Hashtbl.add scache s (Hashtbl.length scache); + addc 'y'; + let s = EvalStdLib.StdStringTools.url_encode s in + add (string_of_int (Rope.length s)); + addc ':'; + add (Rope.to_string s) + in + let cache = ValueHashtbl.create 0 in + let cache_length = ref 0 in + let cache v f = + try + let i = ValueHashtbl.find cache v in + addc 'r'; + add (string_of_int i) + with Not_found -> + let i = !cache_length in + ValueHashtbl.add cache v i; + incr cache_length; + f() + in + let function_count = ref 0 in + let rec loop v = match v with + | VNull -> addc 'n' + | VTrue -> addc 't' + | VFalse -> addc 'f' + | VInt32 i when i = Int32.zero -> addc 'z' + | VInt32 i -> + addc 'i'; + add (Int32.to_string i) + | VFloat f -> + if f = neg_infinity then addc 'm' + else if f = infinity then addc 'p' + else if f <> f then addc 'k' + else begin + addc 'd'; + add (string_of_float f) + end + | VEnumValue ve -> + cache v (fun () -> + addc 'j'; + adds (rev_hash_s ve.epath); + addc ':'; + add (string_of_int ve.eindex); + addc ':'; + add (string_of_int (Array.length ve.eargs)); + Array.iter loop ve.eargs; + ) + | VObject o -> + cache v (fun () -> + addc 'o'; + let fields = object_fields o in + loop_fields fields; + addc 'g' + ) + | VInstance {ikind = IDate f} -> + cache v (fun () -> + addc 'v'; + add (Rope.to_string (s_date f)) + ) + | VInstance {ikind = IStringMap map} -> + cache v (fun() -> + addc 'b'; + StringHashtbl.iter (fun (_,s) value -> + adds (Lazy.force s); + loop value + ) map; + addc 'h' + ) + | VInstance {ikind = IIntMap map} -> + cache v (fun () -> + addc 'q'; + IntHashtbl.iter (fun i value -> + addc ':'; + add (string_of_int i); + loop value + ) map; + addc 'h' + ) + | VInstance {ikind = IObjectMap map} -> + cache v (fun() -> + addc 'M'; + ValueHashtbl.iter (fun key value -> + loop key; + loop value + ) (Obj.magic map); + addc 'h' + ) + | VInstance {ikind = IBytes b} -> + cache v (fun () -> + addc 's'; + let base64_chars = [| + 'A';'B';'C';'D';'E';'F';'G';'H';'I';'J';'K';'L';'M';'N';'O';'P'; + 'Q';'R';'S';'T';'U';'V';'W';'X';'Y';'Z';'a';'b';'c';'d';'e';'f'; + 'g';'h';'i';'j';'k';'l';'m';'n';'o';'p';'q';'r';'s';'t';'u';'v'; + 'w';'x';'y';'z';'0';'1';'2';'3';'4';'5';'6';'7';'8';'9';'%';':' + |] in + let s = Bytes.unsafe_to_string (Base64.str_encode ~tbl:(base64_chars) (Bytes.unsafe_to_string b)) in + add (string_of_int (String.length s)); + addc ':'; + add s + ) + | VInstance i -> + cache v (fun () -> + addc 'c'; + adds (rev_hash_s i.iproto.ppath); + let fields = instance_fields i in + loop_fields fields; + addc 'g'; + ) + | VString(_,s) -> + adds (Lazy.force s) + | VArray {avalues = a} | VVector a -> + cache v (fun () -> + addc 'a'; + let nulls null_count = + if null_count > 0 then begin + addc 'u'; + add (string_of_int null_count); + end + in + let rec loop2 null_count vl = match vl with + | VNull :: vl -> loop2 (null_count + 1) vl + | v :: vl -> + nulls null_count; + loop v; + loop2 0 vl + | [] -> + nulls null_count + in + loop2 0 (Array.to_list a); + addc 'h' + ) + | VPrototype {pkind = PClass _; ppath = path} -> + addc 'A'; + adds (rev_hash_s path) + | VPrototype {pkind = PEnum _; ppath = path} -> + addc 'B'; + adds (rev_hash_s path) + | VPrototype _ -> + assert false + | VFunction _ | VFieldClosure _ -> + (* Custom format: enumerate functions as F0, F1 etc. *) + cache v (fun () -> + addc 'F'; + add (string_of_int !function_count); + incr function_count + ) + and loop_fields fields = + List.iter (fun (name,v) -> + adds (rev_hash_s name); + loop v; + ) fields + in + loop v; + Digest.string (Buffer.contents buf) + +let prepare_callback v n = + match v with + | VFunction _ | VFieldClosure _ -> + let ctx = get_ctx() in + (fun args -> match catch_exceptions ctx (fun() -> call_value v args) null_pos with + | Some v -> v + | None -> vnull) + | _ -> + raise Invalid_expr + +let init ctx = () + +let setup get_api = + let api = get_api (fun() -> (get_ctx()).curapi.get_com()) (fun() -> (get_ctx()).curapi) in + List.iter (fun (n,v) -> match v with + | VFunction(f,b) -> + let v = match f with + | Fun0 f -> VFunction (Fun0 (fun () -> try f () with Sys_error msg | Failure msg -> exc_string msg),b) + | Fun1 f -> VFunction (Fun1 (fun a -> try f a with Sys_error msg | Failure msg -> exc_string msg),b) + | Fun2 f -> VFunction (Fun2 (fun a b -> try f a b with Sys_error msg | Failure msg -> exc_string msg),b) + | Fun3 f -> VFunction (Fun3 (fun a b c -> try f a b c with Sys_error msg | Failure msg -> exc_string msg),b) + | Fun4 f -> VFunction (Fun4 (fun a b c d -> try f a b c d with Sys_error msg | Failure msg -> exc_string msg),b) + | Fun5 f -> VFunction (Fun5 (fun a b c d e -> try f a b c d e with Sys_error msg | Failure msg -> exc_string msg),b) + | FunN f -> VFunction (FunN (fun vl -> try f vl with Sys_error msg | Failure msg -> exc_string msg),b) + in + Hashtbl.replace EvalStdLib.macro_lib n v + | _ -> assert false + ) api; + Globals.macro_platform := Globals.Eval + +let can_reuse ctx types = true + +let do_reuse ctx api = + ctx.curapi <- api + +let set_error ctx b = + (* TODO: Have to reset this somewhere if running compilation server. But where... *) + ctx.had_error <- b + +let add_types ctx types ready = + ignore(catch_exceptions ctx (fun () -> ignore(add_types ctx types ready)) null_pos) + +let compiler_error msg pos = + let vi = encode_instance key_haxe_macro_Error in + match vi with + | VInstance i -> + set_instance_field i key_message (encode_string msg); + set_instance_field i key_pos (encode_pos pos); + exc vi + | _ -> + assert false + +let rec value_to_expr v p = + let path i = + let mt = IntMap.find i (get_ctx()).type_cache in + let make_path t = + let rec loop = function + | [] -> assert false + | [name] -> (EConst (Ident name),p) + | name :: l -> (EField (loop l,name),p) + in + let t = t_infos t in + loop (List.rev (if t.mt_module.m_path = t.mt_path then fst t.mt_path @ [snd t.mt_path] else fst t.mt_module.m_path @ [snd t.mt_module.m_path;snd t.mt_path])) + in + make_path mt + in + match v with + | VNull -> (EConst (Ident "null"),p) + | VTrue -> (EConst (Ident "true"),p) + | VFalse -> (EConst (Ident "false"),p) + | VInt32 i -> (EConst (Int (Int32.to_string i)),p) + | VFloat f -> haxe_float f p + | VString(r,s) -> (EConst (String (Lazy.force s)),p) + | VArray va -> (EArrayDecl (List.map (fun v -> value_to_expr v p) (EvalArray.to_list va)),p) + | VObject o -> (EObjectDecl (List.map (fun (k,v) -> ((rev_hash_s k,p),(value_to_expr v p))) (object_fields o)),p) + | VEnumValue e -> + let epath = + let proto = get_static_prototype_raise (get_ctx()) e.epath in + let expr = path e.epath in + let name = match proto.pkind with + | PEnum names -> List.nth names e.eindex + | _ -> assert false + in + (EField (expr, name), p) + in + begin + match e.eargs with + | [||] -> epath + | _ -> + let args = List.map (fun v -> value_to_expr v p) (Array.to_list e.eargs) in + (ECall (epath, args), p) + end + + | _ -> exc_string ("Cannot convert " ^ (value_string v) ^ " to expr") + +let encode_obj = encode_obj_s + +let field v f = field v (EvalHash.hash_s f) + +let value_string = value_string + +let exc_string = exc_string + +let eval_expr ctx e = eval_expr ctx key_questionmark key_questionmark e \ No newline at end of file diff --git a/src/macro/eval/evalMisc.ml b/src/macro/eval/evalMisc.ml new file mode 100644 index 00000000000..5f963545a76 --- /dev/null +++ b/src/macro/eval/evalMisc.ml @@ -0,0 +1,141 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open Type +open EvalValue +open EvalContext +open EvalEncode +open EvalDecode +open EvalExceptions +open EvalPrinting +open EvalHash + +(* Calls *) + +let call_value v vl = + match v with + | VFunction(f,_) -> call_function f vl + | VFieldClosure(v1,f) -> call_function f (v1 :: vl) + | VInstance {ikind = ILazyType(_,get)} -> get() + | _ -> exc_string ("Cannot call " ^ (value_string v)) + +(* Field setters *) + +let set_proto_field proto name v2 = + proto.pfields.(get_proto_field_index_raise proto name) <- v2 + +let set_instance_field vi name v2 = + vi.ifields.(get_instance_field_index_raise vi.iproto name) <- v2 + +let set_object_field o name v2 = + try + o.ofields.(get_instance_field_index_raise o.oproto name) <- v2; + o.oremoved <- IntMap.remove name o.oremoved; + with Not_found -> + o.oextra <- IntMap.add name v2 o.oextra + +let set_field v1 name v2 = match v1 with + | VObject o -> set_object_field o name v2 + | VPrototype proto -> set_proto_field proto name v2 + | VArray va -> + (* Vector.new does this *) + if name = key_length then begin + EvalArray.set_length va (decode_int v2); + end else + unexpected_value v1 "object" + | VInstance vi -> set_instance_field vi name v2 + | _ -> unexpected_value v1 "object" + +(* Equality/compare *) + +let fcmp (a:float) b = if a = b then CEq else if a < b then CInf else if a > b then CSup else CUndef + +let icmp (a:int32) b = let l = Int32.compare a b in if l = 0 then CEq else if l < 0 then CInf else CSup + +let rec compare a b = + match a, b with + | VNull,VNull -> CEq + | VInt32 a,VInt32 b -> icmp a b + | VFloat a,VFloat b -> fcmp a b + | VFloat a,VInt32 b -> fcmp a (Int32.to_float b) + | VInt32 a,VFloat b -> fcmp (Int32.to_float a) b + | VTrue,VTrue | VFalse,VFalse -> CEq + | VFalse,VTrue -> CInf + | VTrue,VFalse -> CSup + | VString(_,s1),VString(_,s2) -> + let r = String.compare (Lazy.force s1) (Lazy.force s2) in + if r = 0 then CEq else if r < 0 then CInf else CSup + | VFunction(a,_), VFunction(b,_) -> if a == b then CEq else CUndef + | VArray va1,VArray va2 -> if va1 == va2 then CEq else CUndef + | VVector vv1,VVector vv2 -> if vv1 == vv2 then CEq else CUndef + | VObject a,VObject b -> if a == b then CEq else CUndef + | VInstance a,VInstance b -> if a == b then CEq else CUndef + | VPrototype a,VPrototype b -> if a == b then CEq else CUndef + | VEnumValue a,VEnumValue b -> + if a == b then CEq + else if a.eindex < b.eindex then CInf + else if a.eindex > b.eindex then CSup + else if a.epath <> b.epath then CUndef + else if Array.length a.eargs = 0 && Array.length b.eargs = 0 then CEq + else CUndef + | VFieldClosure(v1,f1),VFieldClosure(v2,f2) -> + if f1 != f2 then CUndef + else compare v1 v2 + | _ -> CUndef + +let equals a b = match a,b with + | VInt32 a,VInt32 b -> a = b + | VFloat a,VFloat b -> a = b + | VFloat a,VInt32 b -> a = (Int32.to_float b) + | VInt32 a,VFloat b -> (Int32.to_float a) = b + | VString(r1,s1),VString(r2,s2) -> r1 == r2 || Lazy.force s1 = Lazy.force s2 + | VEnumValue a,VEnumValue b -> a == b || a.eindex = b.eindex && Array.length a.eargs = 0 && Array.length b.eargs = 0 && a.epath = b.epath + | VPrototype proto1,VPrototype proto2 -> proto1.ppath = proto2.ppath + | _ -> a == b + +let rec arrays_equal a1 a2 = + if Array.length a1 <> Array.length a2 then + false + else begin + let rec loop i = + if i = Array.length a1 then true + else if not (equals_structurally a1.(i) a2.(i)) then false + else loop (i + 1) + in + loop 0 + end + +and equals_structurally a b = + match a,b with + | VInt32 a,VInt32 b -> Int32.compare a b = 0 + | VFloat a,VFloat b -> a = b + | VFloat a,VInt32 b -> a = (Int32.to_float b) + | VInt32 a,VFloat b -> (Int32.to_float a) = b + | VString(_,s1),VString(_,s2) -> Lazy.force s1 = Lazy.force s2 + | VArray a,VArray b -> a == b || arrays_equal a.avalues b.avalues + | VVector a,VVector b -> a == b || arrays_equal a b + | VObject a,VObject b -> a == b || arrays_equal a.ofields b.ofields && IntMap.equal equals_structurally a.oextra b.oextra + | VEnumValue a,VEnumValue b -> a == b || a.eindex = b.eindex && arrays_equal a.eargs b.eargs && a.epath = b.epath + | VPrototype proto1,VPrototype proto2 -> proto1.ppath = proto2.ppath + | _ -> a == b + +let is_true v = match v with + | VTrue -> true + | _ -> false \ No newline at end of file diff --git a/src/macro/eval/evalPrinting.ml b/src/macro/eval/evalPrinting.ml new file mode 100644 index 00000000000..bc111269570 --- /dev/null +++ b/src/macro/eval/evalPrinting.ml @@ -0,0 +1,133 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open Type +open EvalValue +open EvalContext +open EvalField +open EvalHash + +open Rope + +let rnull = of_string "null" +let rcomma = of_char ',' +let rtrue = of_string "true" +let rfalse = of_string "false" +let rfun = of_string "#fun" +let rclosure = of_string "#closure" + +let s_date d = + let open Unix in + let t = localtime d in + of_string (Printf.sprintf "%.4d-%.2d-%.2d %.2d:%.2d:%.2d" (t.tm_year + 1900) (t.tm_mon + 1) t.tm_mday t.tm_hour t.tm_min t.tm_sec) + +let rec s_object depth o = + let fields = object_fields o in + let fields = List.map (fun (key,value) -> (concat empty [EvalHash.rev_hash key; of_string ": "; s_value depth value])) fields in + concat empty [ + of_char '{'; + concat rcomma fields; + of_char '}' + ] + +and s_array depth va = + concat empty [ + of_char '['; + EvalArray.join va (s_value 0) rcomma; + of_char ']'; + ] + +and s_vector depth vv = + concat empty [ + of_char '['; + EvalArray.join (EvalArray.create vv) (s_value 0) rcomma; + of_char ']'; + ] + +and s_enum_ctor_name ve = + try + begin match (get_static_prototype_raise (get_ctx()) ve.epath).pkind with + | PEnum names -> (try List.nth names ve.eindex with _ -> "#unknown") + | _ -> raise Not_found + end + with Not_found -> "#unknown" + +and s_enum_value depth ve = + let name = s_enum_ctor_name ve in + match ve.eargs with + | [||] -> of_string name + | vl -> + concat empty [ + of_string name; + of_char '('; + concat rcomma (Array.to_list (Array.map (s_value (depth + 1)) vl)); + of_char ')' + ] + +and s_proto_kind proto = match proto.pkind with + | PClass _ -> concat empty [of_string "Class<"; rev_hash proto.ppath; of_char '>'] + | PEnum _ -> concat empty [of_string "Enum<"; rev_hash proto.ppath; of_char '>'] + | PInstance | PObject -> assert false + +and s_value depth v = + let call_to_string () = + let vf = field_raise v EvalHash.key_toString in + s_value (depth + 1) (call_value_on v vf []) + in + if depth > 5 then of_string "<...>" + else match v with + | VNull -> rnull + | VInt32 i32 -> of_string (Int32.to_string i32) + | VTrue -> rtrue + | VFalse -> rfalse + | VFloat f -> + let s = Common.float_repres f in + let len = String.length s in + of_string (if String.unsafe_get s (len - 1) = '.' then String.sub s 0 (len - 1) else s) + | VFunction (f,_) -> + let s = match num_args f with + | -1 -> "" + | i -> string_of_int i + in + concat2 rfun (Rope.of_string (s)) + | VFieldClosure _ -> rclosure + | VEnumValue ve -> s_enum_value depth ve + | VString(s,_) -> s + | VArray va -> s_array (depth + 1) va + | VVector vv -> s_vector (depth + 1) vv + | VInstance {ikind=IDate d} -> s_date d + | VInstance {ikind=IPos p} -> of_string ("#pos(" ^ Lexer.get_error_pos (Printf.sprintf "%s:%d:") p ^ ")") + | VInstance i -> (try call_to_string () with Not_found -> rev_hash i.iproto.ppath) + | VObject o -> (try call_to_string () with Not_found -> s_object (depth + 1) o) + | VPrototype proto -> + try + call_to_string() + with Not_found -> + s_proto_kind proto + +and call_value_on vthis v vl = + match v with + | VFunction(f,b) -> + let vl = if not b then vthis :: vl else vl in + call_function f vl + | VFieldClosure(v1,f) -> call_function f (v1 :: vl) + | _ -> exc_string ("Cannot call " ^ (value_string v)) + +and value_string v = Rope.to_string (s_value 0 v) \ No newline at end of file diff --git a/src/macro/eval/evalPrototype.ml b/src/macro/eval/evalPrototype.ml new file mode 100644 index 00000000000..342f1d243f3 --- /dev/null +++ b/src/macro/eval/evalPrototype.ml @@ -0,0 +1,328 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open Type +open EvalValue +open EvalContext +open EvalEncode +open EvalHash +open EvalJit +open EvalJitContext +open EvalExceptions +open EvalMisc + +(* JITs expression [e] and executes the result immediately. *) +let eval_expr ctx key name e = + catch_exceptions ctx (fun () -> + let jit,f = jit_expr ctx e in + let num_captures = Hashtbl.length jit.captures in + let info = create_env_info true (file_hash e.epos.pfile) (EKMethod(key,name)) jit.capture_infos in + let env = push_environment ctx info jit.max_num_locals num_captures in + Std.finally (fun _ -> pop_environment ctx env) f env + ) e.Type.epos + +(* Creates constructor function for class [c], if it has a constructor. *) +let create_constructor ctx c = + match c.cl_constructor with + | Some {cf_expr = Some {eexpr = TFunction tf; epos = pos}} when not c.cl_extern -> + let key = path_hash c.cl_path in + let v = lazy (vfunction (jit_tfunction ctx key key_new tf false pos)) in + ctx.constructors <- IntMap.add key v ctx.constructors; + | _ -> + () + +(* + PrototypeBuilder manages the intermediate state of prototypes. Due to mutual dependencies, + prototypes have to be created in multiple steps similar to how types have to be loaded. + + The procedure is as follows: + + 1. Create an instance of [prototype_context] using [create]. + 2. Add fields to it and call [finalize]. + 3. Invoke the function returned by [finalize] to initialize fields. +*) +module PrototypeBuilder = struct + type prototype_context = { + ctx : context; + (* The hashed path of the prototype. *) + key : int; + (* The parent prototype, if exists. *) + parent : vprototype option; + (* The kind of the prototype. *) + kind : vprototype_kind; + (* The fields of the prototype. A field here is a pair of its hashed name and its (lazyfied) value. *) + fields : (int * value Lazy.t) DynArray.t; + (* The instance fields of the prototype. See above. *) + instance_fields : (int * value Lazy.t) DynArray.t; + (* The metadata expression, if exists. *) + meta : texpr option; + (* Whether or not the prototype is static. *) + is_static : bool; + } + + (* Creates a new prototype context using the provided information. *) + let create ctx key parent kind meta = + let is_static = match kind with PClass _ | PEnum _ -> true | PInstance | PObject -> false in + { + ctx = ctx; + key = key; + parent = parent; + kind = kind; + fields = DynArray.create (); + instance_fields = DynArray.create (); + meta = meta; + is_static = is_static; + } + + (* Adds a prototype (static) field. *) + let add_proto_field pctx name v = + DynArray.add pctx.fields (name,v) + + (* Adds an instance (non-static) field. *) + let add_instance_field pctx name v = + DynArray.add pctx.instance_fields (name,v) + + (* Forces the lazy field values and assigns them to the prototype. *) + let initialize_fields pctx proto = + DynArray.iteri (fun i (_,v) -> proto.pfields.(i) <- Lazy.force v) pctx.fields + + (* Processes the field information and returns an initialization function. *) + let finalize pctx = + let ctx = pctx.ctx in + (* Add builtins (from EvalStdLib). *) + let builtins = try IntMap.find pctx.key (if pctx.is_static then ctx.builtins.static_builtins else ctx.builtins.instance_builtins) with Not_found -> [] in + List.iter (fun (s,v) -> + try + let i = DynArray.index_of (fun (name',_) -> name' = s) pctx.fields in + DynArray.set pctx.fields i (s,(lazy v)) + with Not_found -> + add_proto_field pctx s (lazy v) + ) builtins; + (* Add metadata field *) + begin match pctx.meta with + | None -> () + | Some e -> DynArray.add pctx.fields (key___meta__,lazy (match eval_expr ctx pctx.key key___meta__ e with Some e -> e | None -> vnull)) + end; + (* Create the mapping from hashed name to field offset for prototype fields. *) + let _,pnames = DynArray.fold_left (fun (i,acc) (name,_) -> i + 1,IntMap.add name i acc) (0,IntMap.empty) pctx.fields in + let pinstance_names,pinstance_fields,f = if not pctx.is_static then begin + (* Combines parent instance fields with current instance fields. *) + let names,fields = match pctx.parent with + | Some proto -> proto.pinstance_names,proto.pinstance_fields + | None -> IntMap.empty,[||] + in + let a = Array.make (Array.length fields + DynArray.length pctx.instance_fields) vnull in + Array.blit fields 0 a 0 (Array.length fields); + (* Create the mapping from hashed name to field offset for instance fields. *) + let names,_ = DynArray.fold_left (fun (fields,count) (name,v) -> + IntMap.add name count fields,count + 1 + ) (names,Array.length fields) pctx.instance_fields in + names,a,(fun proto -> + DynArray.iteri (fun i (_,v) -> a.(i + Array.length fields) <- Lazy.force v) pctx.instance_fields; + initialize_fields pctx proto; + ) + end else + IntMap.empty,[||],(fun proto -> + initialize_fields pctx proto; + ) + in + (* Create the prototype. *) + let proto = { + ppath = pctx.key; + pfields = Array.make (DynArray.length pctx.fields) vnull; + pnames = pnames; + pinstance_fields = pinstance_fields; + pinstance_names = pinstance_names; + pparent = pctx.parent; + pkind = pctx.kind; + pvalue = vnull; + } in + proto.pvalue <- vprototype proto; + (* Register the prototype. *) + if pctx.is_static then + ctx.static_prototypes <- IntMap.add pctx.key proto ctx.static_prototypes + else begin + ctx.instance_prototypes <- IntMap.add pctx.key proto ctx.instance_prototypes; + if pctx.key = key_String then ctx.string_prototype <- proto; + end; + proto,f +end + +let is_removable_field cf = + Meta.has Meta.Extern cf.cf_meta || Meta.has Meta.Generic cf.cf_meta + +let create_static_prototype ctx mt = + let key = path_hash (t_infos mt).mt_path in + let com = ctx.curapi.MacroApi.get_com() in + let meta = Codegen.build_metadata com mt in + let o = match mt with + | TClassDecl c -> + let pparent = match c.cl_super with + | None -> None + | Some(csup,_) -> Some (get_static_prototype ctx (path_hash csup.cl_path) c.cl_pos) + in + let interfaces = List.map (fun (c,_) -> path_hash c.cl_path) c.cl_implements in + let pctx = PrototypeBuilder.create ctx key pparent (PClass interfaces) meta in + let fields = List.filter (fun cf -> not (is_removable_field cf)) c.cl_ordered_statics in + let delays = DynArray.create() in + if not c.cl_extern then List.iter (fun cf -> match cf.cf_kind,cf.cf_expr with + | Method _,Some {eexpr = TFunction tf; epos = pos} -> + let name = hash_s cf.cf_name in + PrototypeBuilder.add_proto_field pctx name (lazy (vstatic_function (jit_tfunction ctx key name tf true pos))); + | Var _,Some e -> + let name = hash_s cf.cf_name in + PrototypeBuilder.add_proto_field pctx name (lazy vnull); + let i = DynArray.length pctx.PrototypeBuilder.fields - 1 in + DynArray.add delays (fun proto -> proto.pfields.(i) <- (match eval_expr ctx key name e with Some e -> e | None -> vnull)) + | _,None when not (is_extern_field cf) -> + PrototypeBuilder.add_proto_field pctx (hash_s cf.cf_name) (lazy vnull); + | _ -> + () + ) fields; + begin match c.cl_init with + | None -> () + | Some e -> DynArray.add delays (fun _ -> ignore(eval_expr ctx key key___init__ e)) + end; + PrototypeBuilder.finalize pctx,(DynArray.to_list delays) + | TEnumDecl en -> + let pctx = PrototypeBuilder.create ctx key None (PEnum en.e_names) meta in + let enum_field_value ef = match follow ef.ef_type with + | TFun(args,_) -> + let f = match args with + | [] -> Fun0 (fun () -> encode_enum_value key ef.ef_index [||] (Some ef.ef_pos)) + | [_] -> Fun1 (fun a -> encode_enum_value key ef.ef_index [|a|] (Some ef.ef_pos)) + | [_;_] -> Fun2 (fun a b -> encode_enum_value key ef.ef_index [|a;b|] (Some ef.ef_pos)) + | [_;_;_] -> Fun3 (fun a b c -> encode_enum_value key ef.ef_index [|a;b;c|] (Some ef.ef_pos)) + | [_;_;_;_] -> Fun4 (fun a b c d -> encode_enum_value key ef.ef_index [|a;b;c;d|] (Some ef.ef_pos)) + | [_;_;_;_;_] -> Fun5 (fun a b c d e -> encode_enum_value key ef.ef_index [|a;b;c;d;e|] (Some ef.ef_pos)) + | _ -> FunN (fun vl -> encode_enum_value key ef.ef_index (Array.of_list vl) (Some ef.ef_pos)) + in + vstatic_function f + | _ -> encode_enum_value key ef.ef_index [||] (Some ef.ef_pos) + in + PMap.iter (fun name ef -> PrototypeBuilder.add_proto_field pctx (hash_s name ) (lazy (enum_field_value ef))) en.e_constrs; + PrototypeBuilder.finalize pctx,[]; + | TAbstractDecl a -> + let pctx = PrototypeBuilder.create ctx key None (PClass []) meta in + PrototypeBuilder.finalize pctx,[]; + | _ -> + assert false + in + o + +let create_instance_prototype ctx c = + let pparent = match c.cl_super with + | None -> None + | Some(c,_) -> Some (get_instance_prototype ctx (path_hash c.cl_path) c.cl_pos) + in + let key = path_hash c.cl_path in + let pctx = PrototypeBuilder.create ctx key pparent PInstance None in + let fields = List.filter (fun cf -> not (is_removable_field cf)) c.cl_ordered_fields in + if c.cl_extern && c.cl_path <> ([],"String") then + () + else List.iter (fun cf -> match cf.cf_kind,cf.cf_expr with + | Method meth,Some {eexpr = TFunction tf; epos = pos} -> + let name = hash_s cf.cf_name in + let v = lazy (vfunction (jit_tfunction ctx key name tf false pos)) in + if meth = MethDynamic then PrototypeBuilder.add_instance_field pctx name v; + PrototypeBuilder.add_proto_field pctx name v + | Var _,_ when not (is_extern_field cf) -> + let name = hash_s cf.cf_name in + PrototypeBuilder.add_instance_field pctx name (lazy vnull); + | _ -> + () + ) fields; + PrototypeBuilder.finalize pctx + +let get_object_prototype ctx l = + let l = List.sort (fun (i1,_) (i2,_) -> if i1 = i2 then 0 else if i1 < i2 then -1 else 1) l in + let sfields = String.concat "," (List.map (fun (i,_) -> rev_hash_s i) l) in + let key = Hashtbl.hash sfields in + try + IntMap.find key ctx.instance_prototypes,l + with Not_found -> + let name = hash_s (Printf.sprintf "eval.object.Object[%s]" sfields) in + let pctx = PrototypeBuilder.create ctx name None PObject None in + List.iter (fun (name,_) -> PrototypeBuilder.add_instance_field pctx name (lazy vnull)) l; + let proto = fst (PrototypeBuilder.finalize pctx) in + ctx.instance_prototypes <- IntMap.add key proto ctx.instance_prototypes; + proto,l + +let add_types ctx types ready = + let t = Common.timer [(if ctx.is_macro then "macro" else "interp");"add_types"] in + let new_types = List.filter (fun mt -> + let inf = Type.t_infos mt in + let key = path_hash inf.mt_path in + try + let inf' = t_infos (IntMap.find key ctx.type_cache) in + if inf'.mt_module.m_id <> inf.mt_module.m_id then raise Not_found; + false + with Not_found -> + ctx.instance_prototypes <- IntMap.remove key ctx.instance_prototypes; + ctx.static_prototypes <- IntMap.remove key ctx.static_prototypes; + ctx.constructors <- IntMap.remove key ctx.constructors; + ready mt; + ctx.type_cache <- IntMap.add key mt ctx.type_cache; + if ctx.debug.support_debugger then begin + let file_key = hash_s inf.mt_module.m_extra.m_file in + if not (Hashtbl.mem ctx.debug.breakpoints file_key) then begin + Hashtbl.add ctx.debug.breakpoints file_key (Hashtbl.create 0) + end + end; + true + ) types in + (* 1. Create prototypes and register them. *) + let fl_instance = DynArray.create () in + let fl_static = DynArray.create () in + List.iter (fun mt -> + match mt with + | TClassDecl c -> + let rec loop p f = + match p with + | Some (p,_) when PMap.mem f.cf_name p.cl_fields || loop p.cl_super f -> + Hashtbl.add ctx.overrides (p.cl_path,f.cf_name) true; + true + | _ -> + false + in + List.iter (fun f -> ignore(loop c.cl_super f)) c.cl_overrides; + create_constructor ctx c; + DynArray.add fl_instance (create_instance_prototype ctx c); + DynArray.add fl_static (create_static_prototype ctx mt); + | TEnumDecl en -> + DynArray.add fl_static (create_static_prototype ctx mt); + | TAbstractDecl a -> + DynArray.add fl_static (create_static_prototype ctx mt); + | _ -> + () + ) new_types; + (* 2. Create instance fields. *) + DynArray.iter (fun (proto,f) -> ignore(f proto)) fl_instance; + (* 3. Create static fields. *) + let fl_static_init = DynArray.create () in + DynArray.iter (fun ((proto,f),delays) -> + f proto; + match delays with + | [] -> () + | _ -> DynArray.add fl_static_init (proto,delays) + ) fl_static; + (* 4. Initialize static fields. *) + DynArray.iter (fun (proto,delays) -> List.iter (fun f -> f proto) delays) fl_static_init; + t() \ No newline at end of file diff --git a/src/macro/eval/evalStdLib.ml b/src/macro/eval/evalStdLib.ml new file mode 100644 index 00000000000..2eb7b0aefd7 --- /dev/null +++ b/src/macro/eval/evalStdLib.ml @@ -0,0 +1,3067 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open EvalValue +open EvalEncode +open EvalDecode +open EvalContext +open EvalExceptions +open EvalPrinting +open EvalMisc +open EvalField +open EvalHash + +let macro_lib = Hashtbl.create 0 + +let ptmap_keys h = + IntMap.fold (fun k _ acc -> k :: acc) h [] + +let hashtbl_keys h = + Hashtbl.fold (fun k _ acc -> k :: acc) h [] + +let encode_i64 low high = + let vi = create_instance key_haxe__Int64____Int64 in + set_instance_field vi key_high (vint32 high); + set_instance_field vi key_low (vint32 low); + vinstance vi + +let encode_i64_direct i64 = + let low = Int64.to_int32 i64 in + let high = Int64.to_int32 (Int64.shift_right_logical i64 32) in + encode_i64 low high + + +module StdEvalVector = struct + let this this = match this with + | VVector vv -> vv + | v -> unexpected_value v "vector" + + let blit = vifun4 (fun vthis srcPos dest destPos len -> + Array.blit (this vthis) (decode_int srcPos) (decode_vector dest) (decode_int destPos) (decode_int len); + vnull + ) + + let toArray = vifun0 (fun vthis -> + let copy = Array.copy (this vthis) in + encode_array_instance (EvalArray.create copy) + ) + + let fromArrayCopy = vfun1 (fun arr -> + encode_vector_instance (Array.copy (decode_varray arr).avalues) + ) + + let copy = vifun0 (fun vthis -> + encode_vector_instance (Array.copy (this vthis)) + ) + + let join = vifun1 (fun vthis sep -> + let this = this vthis in + let sep = decode_rope sep in + encode_rope (EvalArray.array_join this (s_value 0) sep) + ) + + let map = vifun1 (fun vthis f -> + let this = this vthis in + let a = match f with + | VFunction(f,_) -> + begin match f with + | Fun1 f -> Array.map (fun v -> f v) this + | FunN f -> Array.map (fun v -> f [v]) this + | _ -> invalid_call_arg_number 1 (num_args f) + end + | VFieldClosure(v1,f) -> + begin match f with + | Fun2 f -> Array.map (fun v -> f v1 v) this + | FunN f -> Array.map (fun v -> f [v1;v]) this + | _ -> invalid_call_arg_number 2 (num_args f) + end + | _ -> exc_string ("Cannot call " ^ (value_string f)) + in + encode_vector_instance a + ) +end + +module StdArray = struct + let this this = match this with + | VArray va -> va + | v -> unexpected_value v "array" + + let concat = vifun1 (fun vthis a2 -> + let a2 = decode_varray a2 in + encode_array_instance (EvalArray.concat (this vthis) a2) + ) + + let copy = vifun0 (fun vthis -> + encode_array_instance (EvalArray.copy (this vthis)) + ) + + let filter = vifun1 (fun vthis f -> + let this = this vthis in + let a = EvalArray.filter this (fun v -> is_true (call_value_on vthis f [v])) in + encode_array_instance a + ) + + let indexOf = vifun2 (fun vthis x fromIndex -> + let this = this vthis in + let fromIndex = default_int fromIndex 0 in + let fromIndex = if fromIndex < 0 then this.alength + fromIndex else fromIndex in + let fromIndex = if fromIndex < 0 then 0 else fromIndex in + vint (EvalArray.indexOf this equals x fromIndex) + ) + + let insert = vifun2 (fun vthis pos x -> + let this = this vthis in + let pos = decode_int pos in + if pos >= this.alength then begin + ignore(EvalArray.push this x); + end else begin + let pos = if pos < 0 then this.alength + pos else pos in + let pos = if pos < 0 then 0 else pos in + EvalArray.insert this pos x + end; + vnull + ) + + let iterator = vifun0 (fun vthis -> + let this = this vthis in + let f_has_next,f_next = EvalArray.iterator this in + encode_obj None [ + key_hasNext,vifun0 (fun _ -> vbool (f_has_next())); + key_next,vifun0 (fun _ -> f_next()) + ] + ) + + let join = vifun1 (fun vthis sep -> + let sep = decode_rope sep in + let s = EvalArray.join (this vthis) (s_value 0) sep in + encode_rope s + ) + + let lastIndexOf = vifun2 (fun vthis x fromIndex -> + let this = this vthis in + let last = this.alength - 1 in + let fromIndex = default_int fromIndex last in + let fromIndex = if fromIndex < 0 then this.alength + fromIndex else fromIndex in + let fromIndex = if fromIndex < 0 then 0 else if fromIndex > last then last else fromIndex in + vint (EvalArray.lastIndexOf this equals x fromIndex) + ) + + let map = vifun1 (fun vthis f -> + let this = this vthis in + let a = match f with + | VFunction(f,_) -> + begin match f with + | Fun1 f -> EvalArray.map this (fun v -> f v) + | FunN f -> EvalArray.map this (fun v -> f [v]) + | _ -> invalid_call_arg_number 1 (num_args f) + end + | VFieldClosure(v1,f) -> + begin match f with + | Fun2 f -> EvalArray.map this (fun v -> f v1 v) + | FunN f -> EvalArray.map this (fun v -> f [v1;v]) + | _ -> invalid_call_arg_number 2 (num_args f) + end + | _ -> exc_string ("Cannot call " ^ (value_string f)) + in + encode_array_instance a + ) + + let pop = vifun0 (fun vthis -> + let this = this vthis in + EvalArray.pop this + ) + + let push = vifun1 (fun vthis v -> + let this = this vthis in + vint32 (Int32.of_int (EvalArray.push this v)) + ) + + let remove = vifun1 (fun vthis x -> + let this = this vthis in + vbool (EvalArray.remove this equals x) + ) + + let reverse = vifun0 (fun vthis -> + let this = this vthis in + EvalArray.reverse this; + vnull + ) + + let shift = vifun0 (fun vthis -> + let this = this vthis in + EvalArray.shift this + ) + + let slice = vifun2 (fun vthis pos end' -> + let this = this vthis in + let pos = decode_int pos in + let length = this.alength in + let end' = default_int end' length in + let end' = if end' > length then length else end' in + let pos = if pos < 0 then length + pos else pos in + let end' = if end' < 0 then length + end' else end' in + let pos = if pos < 0 then 0 else pos in + let end' = if end' < 0 then 0 else end' in + encode_array_instance (EvalArray.slice this pos end') + ) + + let sort = vifun1 (fun vthis f -> + let this = this vthis in + EvalArray.sort this (fun a b -> decode_int (call_value_on vthis f [a;b])); + vnull + ) + + let splice = vifun2 (fun vthis pos len -> + let this = this vthis in + let pos = decode_int pos in + let len = decode_int len in + let length = this.alength in + if len < 0 || pos > length then + encode_array [] + else begin + let pos = if pos < 0 then length + pos else pos in + let pos = if pos < 0 then 0 else pos in + let delta = length - pos in + let len = if len > delta then delta else len in + let end' = pos + len in + encode_array_instance (EvalArray.splice this pos len end') + end + ) + + let toString = vifun0 (fun vthis -> + encode_rope (s_array 0 (this vthis)) + ) + + let unshift = vifun1 (fun vthis v -> + let this = this vthis in + EvalArray.unshift this v; + vnull + ) +end + +let outside_bounds () = + let haxe_io_Error = get_static_prototype (get_ctx()) key_haxe_io_Error null_pos in + exc (proto_field_direct haxe_io_Error key_OutsideBounds) + +module StdBytes = struct + let this vthis = match vthis with + | VInstance {ikind = IBytes o} -> o + | v -> unexpected_value v "bytes" + + let read_byte this i = int_of_char (Bytes.get this i) + + let read_ui16 this i = + let ch1 = read_byte this i in + let ch2 = read_byte this (i + 1) in + ch1 lor (ch2 lsl 8) + + let read_i32 this i = + let ch1 = read_byte this i in + let ch2 = read_byte this (i + 1) in + let ch3 = read_byte this (i + 2) in + let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in + let big = Int32.shift_left (Int32.of_int (read_byte this (i + 3))) 24 in + Int32.logor base big + + let read_i64 this i = + let ch1 = read_byte this i in + let ch2 = read_byte this (i + 1) in + let ch3 = read_byte this (i + 2) in + let ch4 = read_byte this (i + 3) in + let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in + let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in + let big = Int64.of_int32 (read_i32 this (i + 4)) in + Int64.logor (Int64.shift_left big 32) small + + let write_byte this i v = + Bytes.set this i (Char.unsafe_chr v) + + let write_ui16 this i v = + write_byte this i v; + write_byte this (i + 1) (v lsr 8) + + let write_i32 this i v = + let base = Int32.to_int v in + let big = Int32.to_int (Int32.shift_right_logical v 24) in + write_byte this i base; + write_byte this (i + 1) (base lsr 8); + write_byte this (i + 2) (base lsr 16); + write_byte this (i + 3) big + + let write_i64 this i v = + write_i32 this i (Int64.to_int32 v); + write_i32 this (i + 4) (Int64.to_int32 (Int64.shift_right_logical v 32)) + + let alloc = vfun1 (fun length -> + let length = decode_int length in + encode_bytes (Bytes.make length (Char.chr 0)) + ) + + let blit = vifun4 (fun vthis pos src srcpos len -> + let s = this vthis in + let pos = decode_int pos in + let src = decode_bytes src in + let srcpos = decode_int srcpos in + let len = decode_int len in + (try Bytes.blit src srcpos s pos len with _ -> outside_bounds()); + vnull + ) + + let compare = vifun1 (fun vthis other -> + let this = this vthis in + let other = decode_bytes other in + vint (Pervasives.compare this other) + ) + + let fastGet = vfun2 (fun b pos -> + let b = decode_bytes b in + let pos = decode_int pos in + try vint (int_of_char (Bytes.unsafe_get b pos)) with _ -> vnull + ) + + let fill = vifun3 (fun vthis pos len value -> + let this = this vthis in + let pos = decode_int pos in + let len = decode_int len in + let value = decode_int value in + (try Bytes.fill this pos len (char_of_int value) with _ -> outside_bounds()); + vnull + ) + + let get = vifun1 (fun vthis pos -> + let this = this vthis in + let pos = decode_int pos in + try vint (read_byte this pos) with _ -> vnull + ) + + let getData = vifun0 (fun vthis -> vthis) + + let getDouble = vifun1 (fun vthis pos -> + try vfloat (Int64.float_of_bits (read_i64 (this vthis) (decode_int pos))) with _ -> outside_bounds() + ) + + let getFloat = vifun1 (fun vthis pos -> + try vfloat (Int32.float_of_bits (read_i32 (this vthis) (decode_int pos))) with _ -> outside_bounds() + ) + + let getInt32 = vifun1 (fun vthis pos -> + try vint32 (read_i32 (this vthis) (decode_int pos)) with exc -> outside_bounds() + ) + + let getInt64 = vifun1 (fun vthis pos -> + let this = this vthis in + let pos = decode_int pos in + try + let low = read_i32 this pos in + let high = read_i32 this (pos + 4) in + encode_i64 low high; + with _ -> + outside_bounds() + ) + + let getString = vifun2 (fun vthis pos len -> + let this = this vthis in + let pos = decode_int pos in + let len = decode_int len in + encode_string (Bytes.unsafe_to_string ((try Bytes.sub this pos len with _ -> outside_bounds()))); + ) + + let getUInt16 = vifun1 (fun vthis pos -> + try vint (read_ui16 (this vthis) (decode_int pos)) with _ -> outside_bounds() + ) + + let ofData = vfun1 (fun v -> v) + + let ofString = vfun1 (fun v -> + encode_bytes (Bytes.of_string (decode_string v)) + ) + + let set = vifun2 (fun vthis pos v -> + let this = this vthis in + let pos = decode_int pos in + let v = decode_int v in + (try write_byte this pos v with _ -> ()); + vnull; + ) + + let setDouble = vifun2 (fun vthis pos v -> + (try write_i64 (this vthis) (decode_int pos) (Int64.bits_of_float (decode_float v)) with _ -> outside_bounds()); + vnull + ) + + let setFloat = vifun2 (fun vthis pos v -> + let this = this vthis in + let pos = decode_int pos in + let v = num v in + write_i32 this pos (Int32.bits_of_float v); + vnull + ) + + let setInt32 = vifun2 (fun vthis pos v -> + (try write_i32 (this vthis) (decode_int pos) (decode_i32 v) with _ -> outside_bounds()); + vnull; + ) + + let setInt64 = vifun2 (fun vthis pos v -> + let v = decode_instance v in + let pos = decode_int pos in + let high = decode_i32 (instance_field v key_high) in + let low = decode_i32 (instance_field v key_low) in + let this = this vthis in + try + write_i32 this pos low; + write_i32 this (pos + 4) high; + vnull + with _ -> + outside_bounds() + ) + + let setUInt16 = vifun2 (fun vthis pos v -> + (try write_ui16 (this vthis) (decode_int pos) (decode_int v land 0xFFFF) with _ -> outside_bounds()); + vnull + ) + + let sub = vifun2 (fun vthis pos len -> + let this = this vthis in + let pos = decode_int pos in + let len = decode_int len in + let s = try Bytes.sub this pos len with _ -> outside_bounds() in + encode_bytes s + ) + + let toHex = vifun0 (fun vthis -> + let this = this vthis in + let chars = [|"0";"1";"2";"3";"4";"5";"6";"7";"8";"9";"a";"b";"c";"d";"e";"f"|] in + let l = Bytes.length this in + let rec loop acc i = + if i >= l then List.rev acc + else begin + let c = int_of_char (Bytes.get this i) in + loop ((chars.(c land 15)) :: ((chars.(c lsr 4))) :: acc) (i + 1) + end + in + encode_string (String.concat "" (loop [] 0)) + ) + + let toString = vifun0 (fun vthis -> + encode_string (Bytes.to_string (this vthis)) + ) +end + +module StdBytesBuffer = struct + let this vthis = match vthis with + | VInstance {ikind = IOutput o} -> o + | v -> unexpected_value v "output" + + let get_length = vifun0 (fun vthis -> + let this = this vthis in + vint (Buffer.length this) + ) + + let add_char this i = + Buffer.add_char this (Char.unsafe_chr i) + + let add_i32 this v = + let base = Int32.to_int v in + let big = Int32.to_int (Int32.shift_right_logical v 24) in + add_char this base; + add_char this (base lsr 8); + add_char this (base lsr 16); + add_char this big + + let addByte = vifun1 (fun vthis byte -> + let this = this vthis in + let byte = decode_int byte in + add_char this byte; + vnull; + ) + + let add = vifun1 (fun vthis src -> + let this = this vthis in + let src = decode_bytes src in + Buffer.add_bytes this src; + vnull + ) + + let addString = vifun1 (fun vthis src -> + let this = this vthis in + let src = decode_string src in + Buffer.add_string this src; + vnull + ) + + let addInt32 = vifun1 (fun vthis v -> + let this = this vthis in + let v = decode_i32 v in + add_i32 this v; + vnull + ) + + let addInt64 = vifun1 (fun vthis v -> + let this = this vthis in + let v = decode_instance v in + let high = decode_i32 (instance_field v key_high) in + let low = decode_i32 (instance_field v key_low) in + add_i32 this low; + add_i32 this high; + vnull; + ) + + let addFloat = vifun1 (fun vthis v -> + let this = this vthis in + let v = num v in + add_i32 this (Int32.bits_of_float v); + vnull + ) + + let addDouble = vifun1 (fun vthis v -> + let this = this vthis in + let v = num v in + let v = Int64.bits_of_float v in + add_i32 this (Int64.to_int32 v); + add_i32 this (Int64.to_int32 (Int64.shift_right_logical v 32)); + vnull + ) + + let addBytes = vifun3 (fun vthis src pos len -> + let this = this vthis in + let src = decode_bytes src in + let pos = decode_int pos in + let len = decode_int len in + if pos < 0 || len < 0 || pos + len > Bytes.length src then outside_bounds(); + Buffer.add_subbytes this src pos len; + vnull + ) + + let getBytes = vifun0 (fun vthis -> + let this = this vthis in + encode_bytes (Bytes.unsafe_of_string (Buffer.contents this)) + ) +end + +module StdCallStack = struct + let make_stack envs = + let l = DynArray.create () in + List.iter (fun (pos,kind) -> + let file_pos s = + let line = Lexer.get_error_line pos in + encode_enum_value key_haxe_StackItem 2 [|s;encode_string pos.pfile;vint line|] None + in + match kind with + | EKLocalFunction i -> + let local_function = encode_enum_value key_haxe_StackItem 4 [|vint i|] None in + DynArray.add l (file_pos local_function); + | EKMethod(st,sf) -> + let local_function = encode_enum_value key_haxe_StackItem 3 [|encode_string (rev_hash_s st); encode_string (rev_hash_s sf)|] None in + DynArray.add l (file_pos local_function); + | EKDelayed -> + () + ) envs; + encode_array (DynArray.to_list l) + + let getCallStack = vfun0 (fun () -> + let ctx = get_ctx() in + let envs = call_stack ctx in + let envs = match envs with + | _ :: _ :: envs -> envs (* Skip calls to callStack() and getCallStack() *) + | _ -> envs + in + make_stack (List.map (fun env -> {pfile = rev_hash_s env.env_info.pfile;pmin = env.env_leave_pmin; pmax = env.env_leave_pmax},env.env_info.kind) envs) + ) + + let getExceptionStack = vfun0 (fun () -> + let ctx = get_ctx() in + let envs = ctx.exception_stack in + make_stack (List.rev envs) + ) +end + +module StdCompress = struct + open Extc + + type zfun = zstream -> src:string -> spos:int -> slen:int -> dst:bytes -> dpos:int -> dlen:int -> zflush -> zresult + + let this vthis = match vthis with + | VInstance {ikind = IZip zip} -> zip + | _ -> unexpected_value vthis "Compress" + + let exec (f : zfun) vthis src srcPos dst dstPos = + let this = this vthis in + let src = decode_bytes src in + let srcPos = decode_int srcPos in + let dst = decode_bytes dst in + let dstPos = decode_int dstPos in + let r = try f this.z (Bytes.unsafe_to_string src) srcPos (Bytes.length src - srcPos) dst dstPos (Bytes.length dst - dstPos) this.z_flush with _ -> exc_string "oops" in + encode_obj None [ + key_done,vbool r.z_finish; + key_read,vint r.z_read; + key_write,vint r.z_wrote + ] + + let close = vifun0 (fun vthis -> + zlib_deflate_end (this vthis).z; + vnull + ) + + let execute = vifun4 (fun vthis src srcPos dst dstPos -> + exec zlib_deflate vthis src srcPos dst dstPos + ) + + let run = vfun2 (fun s level -> + let s = decode_bytes s in + let level = decode_int level in + let zip = zlib_deflate_init level in + let d = Bytes.make (zlib_deflate_bound zip (Bytes.length s)) (char_of_int 0) in + let r = zlib_deflate zip (Bytes.unsafe_to_string s) 0 (Bytes.length s) d 0 (Bytes.length d) Z_FINISH in + zlib_deflate_end zip; + if not r.z_finish || r.z_read <> (Bytes.length s) then exc_string "Compression failed"; + encode_bytes (Bytes.sub d 0 r.z_wrote) + ) + + let setFlushMode = vifun1 (fun vthis f -> + let mode = match fst (decode_enum f) with + | 0 -> Z_NO_FLUSH + | 1 -> Z_SYNC_FLUSH + | 2 -> Z_FULL_FLUSH + | 3 -> Z_FINISH + | 4 -> Z_PARTIAL_FLUSH + | _ -> assert false + in + (this vthis).z_flush <- mode; + vnull + ) +end + +module StdContext = struct + let addBreakpoint = vfun2 (fun file line -> + let file = decode_string file in + let line = decode_int line in + begin try + ignore(EvalDebugMisc.add_breakpoint (get_ctx()) file line BPAny); + with Not_found -> + exc_string ("Could not find file " ^ file) + end; + vnull + ) + + let breakHere = vfun0 (fun () -> + raise (EvalDebugMisc.BreakHere) + ) + + let callMacroApi = vfun1 (fun f -> + let f = decode_string f in + Hashtbl.find macro_lib f + ) + + let plugin_data = ref None + + let register data = plugin_data := Some data + + let loadPlugin = vfun1 (fun filePath -> + let filePath = decode_string filePath in + let filePath = Dynlink.adapt_filename filePath in + (try Dynlink.loadfile filePath with Dynlink.Error error -> exc_string (Dynlink.error_message error)); + match !plugin_data with + | None -> + vnull + | Some l -> + encode_obj_s None l + ) +end + +module StdCrc32 = struct + let make = vfun1 (fun data -> + let data = decode_bytes data in + let crc32 = Extc.zlib_crc32 data (Bytes.length data) in + vint crc32 + ) +end + +module StdDate = struct + open Unix + + let encode_date d = encode_instance key_Date ~kind:(IDate d) + + let this vthis = match vthis with + | VInstance {ikind = IDate d} -> d + | v -> unexpected_value v "date" + + let fromTime = vfun1 (fun f -> encode_date ((num f) /. 1000.)) + + let fromString = vfun1 (fun s -> + let s = decode_string s in + match String.length s with + | 19 -> + let r = Str.regexp "^\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\) \\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)$" in + if not (Str.string_match r s 0) then exc_string ("Invalid date format : " ^ s); + let t = Unix.localtime (Unix.time()) in + let t = { t with + tm_year = int_of_string (Str.matched_group 1 s) - 1900; + tm_mon = int_of_string (Str.matched_group 2 s) - 1; + tm_mday = int_of_string (Str.matched_group 3 s); + tm_hour = int_of_string (Str.matched_group 4 s); + tm_min = int_of_string (Str.matched_group 5 s); + tm_sec = int_of_string (Str.matched_group 6 s); + } in + encode_date (fst (Unix.mktime t)) + | _ -> + exc_string ("Invalid date format : " ^ s) + ) + + let getDate = vifun0 (fun vthis -> vint (localtime (this vthis)).tm_mday) + let getDay = vifun0 (fun vthis -> vint (localtime (this vthis)).tm_wday) + let getFullYear = vifun0 (fun vthis -> vint (((localtime (this vthis)).tm_year) + 1900)) + let getHours = vifun0 (fun vthis -> vint (localtime (this vthis)).tm_hour) + let getMinutes = vifun0 (fun vthis -> vint (localtime (this vthis)).tm_min) + let getMonth = vifun0 (fun vthis -> vint (localtime (this vthis)).tm_mon) + let getSeconds = vifun0 (fun vthis -> vint (localtime (this vthis)).tm_sec) + let getTime = vifun0 (fun vthis -> vfloat ((this vthis) *. 1000.)) + let now = vfun0 (fun () -> encode_date (time())) + let toString = vifun0 (fun vthis -> encode_rope (s_date (this vthis))) +end + +module StdEReg = struct + open Pcre + + let create r opt = + let open Pcre in + let string_of_pcre_error = function + | BadPattern(s,i) -> Printf.sprintf "at %i: %s" i s + | Partial -> "Partial" + | BadPartial -> "BadPartial" + | BadUTF8 -> "BadUTF8" + | BadUTF8Offset -> "BadUTF8Offset" + | MatchLimit -> "MatchLimit" + | RecursionLimit -> "RecursionLimit" + | InternalError s -> "InternalError: " ^ s + in + let global = ref false in + let flags = ExtList.List.filter_map (function + | 'i' -> Some `CASELESS + | 's' -> Some `DOTALL + | 'm' -> Some `MULTILINE + | 'u' -> Some `UTF8 + | 'g' -> global := true; None + | c -> failwith ("Unsupported regexp option '" ^ String.make 1 c ^ "'") + ) (ExtString.String.explode opt) in + let r = try regexp ~flags r with Error error -> failwith (string_of_pcre_error error) in + let pcre = { + r = r; + r_global = !global; + r_string = ""; + r_groups = [||] + } in + IRegex pcre + + let maybe_run rex n f = + let substrings = if Array.length rex.r_groups = 0 then exc_string "Invalid regex operation because no match was made" else rex.r_groups.(0) in + if n < 0 || n >= num_of_subs substrings then exc_string "Invalid group" + else try f (get_substring_ofs substrings n) + with Not_found -> vnull + + let this this = match this with + | VInstance {ikind = IRegex rex} -> rex + | v -> unexpected_value v "EReg" + + let escape = vfun1 (fun s -> + let s = decode_string s in + encode_string (Str.quote s) + ) + + let map = vifun2 (fun vthis s f -> + let this = this vthis in + let s = decode_string s in + let l = String.length s in + let buf = Rope.Buffer.create 0 in + let rec loop pos = + if pos >= l then + () + else begin try + let a = exec ~rex:this.r ~pos s in + this.r_groups <- [|a|]; + let (first,last) = get_substring_ofs a 0 in + Rope.Buffer.add_substring buf s pos (first - pos); + Rope.Buffer.add_rope buf (decode_rope (call_value_on vthis f [vthis])); + if last = first then begin + if last >= l then + () + else begin + if this.r_global then begin + Rope.Buffer.add_substring buf s first 1; + loop (first + 1) + end else + Rope.Buffer.add_substring buf s first (l - first) + end + end else if this.r_global then + loop last + else + Rope.Buffer.add_substring buf s last (l - last) + with Not_found -> + Rope.Buffer.add_substring buf s pos (l - pos) + end + in + this.r_string <- s; + loop 0; + this.r_string <- ""; + this.r_groups <- [||]; + encode_rope (Rope.Buffer.contents buf) + ) + + let match' = vifun1 (fun vthis s -> + let this = this vthis in + let open Pcre in + let s = decode_string s in + this.r_string <- s; + try + let a = exec_all ~rex:this.r s in + this.r_groups <- a; + vtrue + with Not_found -> + this.r_groups <- [||]; + vfalse + ) + + let matched = vifun1 (fun vthis n -> + let this = this vthis in + let n = decode_int n in + maybe_run this n (fun (first,last) -> + encode_string (ExtString.String.slice ~first ~last this.r_string) + ) + ) + + let matchedLeft = vifun0 (fun vthis -> + let this = this vthis in + maybe_run this 0 (fun (first,_) -> + encode_string (ExtString.String.slice ~last:first this.r_string) + ) + ) + + let matchedPos = vifun0 (fun vthis -> + let this = this vthis in + maybe_run this 0 (fun (first,last) -> + encode_obj None [key_pos,vint first;key_len,vint (last - first)] + ) + ) + + let matchedRight = vifun0 (fun vthis -> + let this = this vthis in + maybe_run this 0 (fun (_,last) -> + encode_string (ExtString.String.slice ~first:last this.r_string) + ) + ) + + let matchSub = vifun3 (fun vthis s pos len -> + let this = this vthis in + let s = decode_string s in + let pos = decode_int pos in + let len = default_int len (String.length s - pos) in + begin try + if pos + len > String.length s then raise Not_found; + let str = String.sub s 0 (pos + len) in + let a = Pcre.exec_all ~rex:this.r ~pos str in + this.r_string <- s; + this.r_groups <- a; + vtrue + with Not_found -> + vfalse + end + ) + + let replace = vifun2 (fun vthis s by -> + let this = this vthis in + let s = decode_string s in + let by = decode_string by in + let s = (if this.r_global then Pcre.replace else Pcre.replace_first) ~rex:this.r ~templ:by s in + encode_string s + ) + + let split = vifun1 (fun vthis s -> + let this = this vthis in + let s = decode_string s in + if String.length s = 0 then encode_array [encode_string ""] + else begin + let max = if this.r_global then -1 else 2 in + let l = Pcre.split ~max ~rex:this.r s in + encode_array (List.map encode_string l) + end + ) +end + +module StdFile = struct + let create_out path binary flags = + let path = decode_string path in + let binary = match binary with + | VTrue -> true + | _ -> false + in + let perms = 0o666 in + let l = Open_creat :: flags in + let l = if binary then Open_binary :: l else l in + let ch = open_out_gen l perms path in + encode_instance key_sys_io_FileOutput ~kind:(IOutChannel ch) + + let write_out path content = + try + let ch = open_out_bin path in + output_string ch content; + close_out ch; + vnull + with Sys_error _ -> + exc_string ("Could not write file " ^ path) + + let append = vfun2 (fun path binary -> + create_out path binary [Open_append] + ) + + let getBytes = vfun1 (fun path -> + let path = decode_string path in + try encode_bytes (Bytes.unsafe_of_string (Std.input_file ~bin:true path)) with Sys_error _ -> exc_string ("Could not read file " ^ path) + ) + + let getContent = vfun1 (fun path -> + let path = decode_string path in + try encode_string (Std.input_file ~bin:true path) with Sys_error _ -> exc_string ("Could not read file " ^ path) + ) + + let read = vfun2 (fun path binary -> + let path = decode_string path in + let binary = match binary with + | VTrue -> true + | _ -> false + in + let ch = open_in_gen (Open_rdonly :: (if binary then [Open_binary] else [])) 0 path in + encode_instance key_sys_io_FileInput ~kind:(IInChannel(ch,ref false)) + ) + + let saveBytes = vfun2 (fun path bytes -> + let path = decode_string path in + let bytes = decode_bytes bytes in + write_out path (Bytes.unsafe_to_string bytes) + ) + + let saveContent = vfun2 (fun path content -> + let path = decode_string path in + let content = decode_string content in + write_out path content + ) + + let write = vfun2 (fun path binary -> + create_out path binary [Open_wronly;Open_trunc] + ) +end + +module StdFileInput = struct + let raise_eof () = + let v = encode_instance key_haxe_io_Eof in + exc v + + let this vthis = match vthis with + | VInstance {ikind = IInChannel(ch,eof)} -> ch,eof + | _ -> unexpected_value vthis "FileInput" + + let close = vifun0 (fun vthis -> + close_in (fst (this vthis)); + vnull + ) + + let eof = vifun0 (fun vthis -> + vbool !(snd (this vthis)) + ) + + let seek = vifun2 (fun vthis pos mode -> + let ch,r = this vthis in + r := false; + let pos = decode_int pos in + let mode,_ = decode_enum mode in + seek_in ch (match mode with 0 -> pos | 1 -> pos_in ch + pos | 2 -> in_channel_length ch + pos | _ -> assert false); + vnull + ) + + let tell = vifun0 (fun vthis -> + vint (pos_in (fst (this vthis))) + ) + + let readByte = vifun0 (fun vthis -> + let ch,r = this vthis in + let i = try + input_char ch + with _ -> + r := true; + raise_eof() + in + vint (int_of_char i) + ) + + let readBytes = vifun3 (fun vthis bytes pos len -> + let ch,r = this vthis in + let bytes = decode_bytes bytes in + let pos = decode_int pos in + let len = decode_int len in + let i = input ch bytes pos len in + if i = 0 then begin + r := true; + raise_eof() + end; + vint i + ) +end + +module StdFileOutput = struct + let this vthis = match vthis with + | VInstance {ikind = IOutChannel ch} -> ch + | _ -> unexpected_value vthis "FileOutput" + + let close = vifun0 (fun vthis -> + close_out (this vthis); + vnull + ) + + let flush = vifun0 (fun vthis -> + flush (this vthis); + vnull + ) + + let seek = vifun2 (fun vthis pos mode -> + let this = this vthis in + let pos = decode_int pos in + let mode,_ = decode_enum mode in + seek_out this (match mode with 0 -> pos | 1 -> pos_out this + pos | 2 -> out_channel_length this + pos | _ -> assert false); + vnull + ) + + let tell = vifun0 (fun vthis -> + vint (pos_out (this vthis)) + ) + + let writeByte = vifun1 (fun vthis c -> + output_char (this vthis) (char_of_int (decode_int c)); + vnull + ) + + let writeBytes = vifun3 (fun vthis bytes pos len -> + let this = this vthis in + let bytes = decode_bytes bytes in + let pos = decode_int pos in + let len = decode_int len in + output this bytes pos len; + vint len + ) +end + +module StdFPHelper = struct + let doubleToI64 = vfun1 (fun v -> + let f = num v in + let i64 = Int64.bits_of_float f in + encode_i64_direct i64 + ) + + let floatToI32 = vfun1 (fun f -> + let f = num f in + let i32 = Int32.bits_of_float f in + vint32 i32 + ) + + let i32ToFloat = vfun1 (fun i -> + let i32 = decode_i32 i in + let f = Int32.float_of_bits i32 in + vfloat f + ) + + let i64ToDouble = vfun2 (fun low high -> + let low = decode_i32 low in + let high = decode_i32 high in + let b = Bytes.make 8 '0' in + StdBytes.write_i32 b 0 low; + StdBytes.write_i32 b 4 high; + let i64 = StdBytes.read_i64 b 0 in + vfloat (Int64.float_of_bits i64) + ) +end + +module StdFileSystem = struct + let rec remove_trailing_slash p = + let l = String.length p in + if l = 0 then + "" (* don't be retarded *) + else match p.[l-1] with + | '\\' | '/' -> remove_trailing_slash (String.sub p 0 (l - 1)) + | _ -> p + + let patch_path s = + if String.length s > 0 && String.length s <= 3 && s.[1] = ':' then Path.add_trailing_slash s + else remove_trailing_slash s + + let absolutePath = vfun1 (fun relPath -> + encode_string (Path.unique_full_path (decode_string relPath)) + ) + + let createDirectory = vfun1 (fun path -> + (try Common.mkdir_from_path (Path.add_trailing_slash (decode_string path)) with Unix.Unix_error (_,cmd,msg) -> exc_string (cmd ^ " " ^ msg)); + vnull + ) + + let deleteDirectory = vfun1 (fun path -> + (try Unix.rmdir (decode_string path) with Unix.Unix_error (_,cmd,msg) -> exc_string (cmd ^ " " ^ msg)); + vnull + ) + + let deleteFile = vfun1 (fun path -> + (try Sys.remove (decode_string path) with Sys_error s -> exc_string s); + vnull + ) + + let exists = vfun1 (fun path -> + let b = try Sys.file_exists (patch_path (decode_string path)) with Sys_error _ -> false in + vbool b + ) + + let fullPath = vfun1 (fun relPath -> + try encode_string (Extc.get_full_path (decode_string relPath)) with exc -> exc_string (Printexc.to_string exc) + ) + + let isDirectory = vfun1 (fun dir -> + let b = try Sys.is_directory (patch_path(decode_string dir)) with Sys_error _ -> false in + vbool b + ) + + let readDirectory = vfun1 (fun dir -> + let d = try Sys.readdir (decode_string dir) with Sys_error s -> exc_string s in + encode_array (Array.to_list (Array.map (fun s -> encode_string s) d)) + ) + + let rename = vfun2 (fun path newPath -> + (try Sys.rename (decode_string path) (decode_string newPath) with Sys_error s -> exc_string s); + vnull + ) + + let stat = vfun1 (fun path -> + let s = try Unix.stat (patch_path (decode_string path)) with Unix.Unix_error (_,cmd,msg) -> exc_string (cmd ^ " " ^ msg) in + let open Unix in + encode_obj None [ + key_gid,vint s.st_gid; + key_uid,vint s.st_uid; + key_atime,StdDate.encode_date s.st_atime; + key_mtime,StdDate.encode_date s.st_mtime; + key_ctime,StdDate.encode_date s.st_ctime; + key_dev,vint s.st_dev; + key_ino,vint s.st_ino; + key_nlink,vint s.st_nlink; + key_rdev,vint s.st_rdev; + key_size,vint s.st_size; + key_mode,vint s.st_perm; + ] + ) +end + +module StdGc = struct + open Gc + let key_minor_heap_size = hash_s "minor_heap_size" + let key_major_heap_increment = hash_s "major_heap_increment" + let key_space_overhead = hash_s "space_overhead" + let key_verbose = hash_s "verbose" + let key_max_overhead = hash_s "max_overhead" + let key_stack_limit = hash_s "stack_limit" + let key_allocation_policy = hash_s "allocation_policy" + let key_minor_words = hash_s "minor_words" + let key_minor_words = hash_s "minor_words" + let key_promoted_words = hash_s "promoted_words" + let key_major_words = hash_s "major_words" + let key_minor_collections = hash_s "minor_collections" + let key_major_collections = hash_s "major_collections" + let key_heap_words = hash_s "heap_words" + let key_heap_chunks = hash_s "heap_chunks" + let key_live_words = hash_s "live_words" + let key_live_blocks = hash_s "live_blocks" + let key_free_words = hash_s "free_words" + let key_free_blocks = hash_s "free_blocks" + let key_largest_free = hash_s "largest_free" + let key_fragments = hash_s "fragments" + let key_compactions = hash_s "compactions" + let key_top_heap_words = hash_s "top_heap_words" + let key_stack_size = hash_s "stack_size" + + let encode_stats stats = + encode_obj None [ + key_minor_words,vfloat stats.minor_words; + key_promoted_words,vfloat stats.promoted_words; + key_major_words,vfloat stats.major_words; + key_minor_collections,vint stats.minor_collections; + key_major_collections,vint stats.major_collections; + key_heap_words,vint stats.heap_words; + key_heap_chunks,vint stats.heap_chunks; + key_live_words,vint stats.live_words; + key_live_blocks,vint stats.live_blocks; + key_free_words,vint stats.free_words; + key_free_blocks,vint stats.free_blocks; + key_largest_free,vint stats.largest_free; + key_fragments,vint stats.fragments; + key_compactions,vint stats.compactions; + key_top_heap_words,vint stats.top_heap_words; + key_stack_size,vint stats.stack_size; + ] + + let allocated_bytes = vfun0 (fun () -> vfloat (Gc.allocated_bytes())) + + let compact = vfun0 (fun () -> Gc.compact(); vnull ) + + let counters = vfun0 (fun () -> + let (minor_words,promoted_words,major_words) = Gc.counters() in + encode_obj None [ + key_minor_words,vfloat minor_words; + key_promoted_words,vfloat promoted_words; + key_major_words,vfloat major_words; + ] + ) + + let finalise = vfun2 (fun f v -> + let f = fun v -> + ignore(call_value f [v]) + in + Gc.finalise f v; + vnull + ) + + let finalise_release = vfun0 (fun () -> + Gc.finalise_release(); + vnull + ) + + let full_major = vfun0 (fun () -> Gc.full_major(); vnull ) + + let get = vfun0 (fun () -> + let control = Gc.get() in + encode_obj None [ + key_minor_heap_size,vint control.minor_heap_size; + key_major_heap_increment,vint control.major_heap_increment; + key_space_overhead,vint control.space_overhead; + key_verbose,vint control.verbose; + key_max_overhead,vint control.max_overhead; + key_stack_limit,vint control.stack_limit; + key_allocation_policy,vint control.allocation_policy; + ] + ) + + let major = vfun0 (fun () -> Gc.major(); vnull ) + + let major_slice = vfun1 (fun n -> vint (Gc.major_slice (decode_int n))) + + let minor = vfun0 (fun () -> Gc.minor(); vnull ) + + let print_stat = vfun1 (fun out_channel -> + let out_channel = match out_channel with + | VInstance {ikind = IOutChannel ch} -> ch + | _ -> unexpected_value out_channel "Output" + in + Gc.print_stat out_channel; + vnull + ) + + let quick_stat = vfun0 (fun () -> encode_stats (Gc.quick_stat())) + + let set = vfun1 (fun r -> + let r = decode_object r in + let field key = decode_int (object_field r key) in + let control = { (Gc.get()) with + minor_heap_size = field key_minor_heap_size; + major_heap_increment = field key_major_heap_increment; + space_overhead = field key_space_overhead; + verbose = field key_verbose; + max_overhead = field key_max_overhead; + stack_limit = field key_stack_limit; + } in + (* Awkward hack to avoid warning. *) + let control = {control with allocation_policy = field key_allocation_policy} in + Gc.set control; + vnull + ) + + let stat = vfun0 (fun () -> encode_stats (Gc.stat())) +end + +module StdHost = struct + open Unix + + let int32_addr h = + let base = Int32.to_int (Int32.logand h 0xFFFFFFl) in + let str = Printf.sprintf "%ld.%d.%d.%d" (Int32.shift_right_logical h 24) (base lsr 16) ((base lsr 8) land 0xFF) (base land 0xFF) in + inet_addr_of_string str + + let localhost = vfun0 (fun () -> + encode_string (gethostname()) + ) + + let hostReverse = vfun1 (fun ip -> + let ip = decode_i32 ip in + try encode_string (gethostbyaddr (int32_addr ip)).h_name with Not_found -> exc_string "Could not reverse host" + ) + + let hostToString = vfun1 (fun ip -> + let ip = decode_i32 ip in + encode_string (string_of_inet_addr (int32_addr ip)) + ) + + let resolve = vfun1 (fun name -> + let name = decode_string name in + let h = try gethostbyname name with Not_found -> exc_string ("Could not resolve host " ^ name) in + let addr = string_of_inet_addr h.h_addr_list.(0) in + let a, b, c, d = Scanf.sscanf addr "%d.%d.%d.%d" (fun a b c d -> a,b,c,d) in + vint32 (Int32.logor (Int32.shift_left (Int32.of_int a) 24) (Int32.of_int (d lor (c lsl 8) lor (b lsl 16)))) + ) +end + +module StdLog = struct + let key_fileName = hash_s "fileName" + let key_lineNumber = hash_s "lineNumber" + let key_customParams = hash_s "customParams" + + let trace = vfun2 (fun v infos -> + let s = value_string v in + let infos = decode_object infos in + let file_name = decode_string (object_field infos key_fileName) in + let line_number = decode_int (object_field infos key_lineNumber) in + let l = match object_field infos key_customParams with + | VArray va -> s :: (List.map value_string (EvalArray.to_list va)) + | _ -> [s] + in + ((get_ctx()).curapi.MacroApi.get_com()).Common.print (Printf.sprintf "%s:%i: %s\n" file_name line_number (String.concat "," l)); + vnull + ) +end + +let encode_list_iterator l = + let l = ref l in + encode_obj None [ + key_hasNext,vifun0 (fun _ -> + match !l with [] -> vfalse | _ -> vtrue + ); + key_next,vifun0 (fun _ -> match !l with + | [] -> vnull + | v :: l' -> l := l'; v + ) + ] + +module StdMap (Hashtbl : Hashtbl.S) = struct + let map_fields enc dec str this = [ + "get",vifun1 (fun vthis vkey -> try Hashtbl.find (this vthis) (dec vkey) with Not_found -> vnull); + "set",vifun2 (fun vthis vkey vvalue -> Hashtbl.replace (this vthis) (dec vkey) vvalue; vnull); + "exists",vifun1 (fun vthis vkey -> vbool (Hashtbl.mem (this vthis) (dec vkey))); + "remove",vifun1 (fun vthis vkey -> + let key = dec vkey in + let b = Hashtbl.mem (this vthis) key in + Hashtbl.remove (this vthis) key; + vbool b + ); + "keys",vifun0 (fun vthis -> + let keys = Hashtbl.fold (fun v _ acc -> (enc v) :: acc) (this vthis) [] in + encode_list_iterator keys + ); + "iterator",vifun0 (fun vthis -> + let keys = Hashtbl.fold (fun _ v acc -> v :: acc) (this vthis) [] in + encode_list_iterator keys + ); + "toString",vifun0 (fun vthis -> + let open Rope in + let s = concat empty [ + of_char '{'; + concat rcomma + (Hashtbl.fold (fun key vvalue acc -> (concat empty [str key; of_string " => "; s_value 0 vvalue]) :: acc) (this vthis) []) + ; + of_char '}' + ] in + encode_rope s + ); + ] +end + +module StdStringMap = StdMap(StringHashtbl) +module StdIntMap = StdMap(IntHashtbl) +module StdObjectMap = StdMap(ValueHashtbl) + +let random = Random.State.make_self_init() + +module StdMath = struct + let to_int f = Int32.of_float (mod_float f 2147483648.0) + + let nan = vfloat nan + let negative_infinity = vfloat neg_infinity + let pi = vfloat (4.0 *. atan 1.0) + let positive_infinity = vfloat infinity + + let abs = vfun1 (fun v -> + match v with + | VInt32 i -> vint32 (Int32.abs i) + | VFloat f -> vfloat (abs_float f) + | _ -> unexpected_value v "number" + ) + + let acos = vfun1 (fun v -> vfloat (acos (num v))) + let asin = vfun1 (fun v -> vfloat (asin (num v))) + let atan = vfun1 (fun v -> vfloat (atan (num v))) + let atan2 = vfun2 (fun a b -> vfloat (atan2 (num a) (num b))) + let ceil = vfun1 (fun v -> match v with VInt32 _ -> v | _ -> vint32 (to_int (ceil (num v)))) + let cos = vfun1 (fun v -> vfloat (cos (num v))) + let exp = vfun1 (fun v -> vfloat (exp (num v))) + let fceil = vfun1 (fun v -> vfloat (Pervasives.ceil (num v))) + let ffloor = vfun1 (fun v -> vfloat (Pervasives.floor (num v))) + let floor = vfun1 (fun v -> match v with VInt32 _ -> v | _ -> vint32 (to_int (floor (num v)))) + let fround = vfun1 (fun v -> vfloat (Pervasives.floor (num v +. 0.5))) + let isFinite = vfun1 (fun v -> vbool (match v with VFloat f -> f <> infinity && f <> neg_infinity && f = f | _ -> true)) + let isNaN = vfun1 (fun v -> vbool (match v with VFloat f -> f <> f | VInt32 _ -> false | _ -> true)) + let log = vfun1 (fun v -> vfloat (Pervasives.log (num v))) + + let max = vfun2 (fun a b -> + let a = num a in + let b = num b in + vfloat (if a < b then b else if b <> b then b else a); + ) + + let min = vfun2 (fun a b -> + let a = num a in + let b = num b in + vfloat (if a < b then a else if a <> a then a else b); + ) + + let pow = vfun2 (fun a b -> vfloat ((num a) ** (num b))) + let random = vfun0 (fun () -> vfloat (Random.State.float random 1.)) + let round = vfun1 (fun v -> match v with VInt32 _ -> v | _ -> vint32 (to_int (Pervasives.floor (num v +. 0.5)))) + let sin = vfun1 (fun v -> vfloat (sin (num v))) + + let sqrt = vfun1 (fun v -> + let v = num v in + if v < 0. then nan else vfloat (sqrt v) + ) + + let tan = vfun1 (fun v -> vfloat (tan (num v))) +end + +module StdMd5 = struct + let encode = vfun1 (fun s -> + let s = decode_string s in + encode_string (Digest.to_hex (Digest.string s)) + ) + + let make = vfun1 (fun b -> + let b = decode_bytes b in + encode_bytes (Bytes.unsafe_of_string (Digest.string (Bytes.unsafe_to_string b))) + ) +end + +module StdNativeProcess = struct + + let this vthis = match vthis with + | VInstance {ikind=IProcess proc} -> proc + | _ -> unexpected_value vthis "NativeProcess" + + let call f vthis bytes pos len = + let this = this vthis in + let bytes = decode_bytes bytes in + let pos = decode_int pos in + let len = decode_int len in + f this (Bytes.unsafe_to_string bytes) pos len + + let close = vifun0 (fun vthis -> + Process.close (this vthis); + vnull + ) + + let exitCode = vifun0 (fun vthis -> + vint (Process.exit (this vthis)) + ) + + let getPid = vifun0 (fun vthis -> + vint (Process.pid (this vthis)) + ) + + let kill = vifun0 (fun vthis -> + Process.kill (this vthis); + vnull + ) + + let readStderr = vifun3 (fun vthis bytes pos len -> + try vint (call Process.read_stderr vthis bytes pos len) with _ -> exc_string "Could not read stderr" + ) + + let readStdout = vifun3 (fun vthis bytes pos len -> + try vint (call Process.read_stdout vthis bytes pos len) with _ -> exc_string "Could not read stdout" + ) + + let closeStdin = vifun0 (fun vthis -> + Process.close_stdin (this vthis); + vnull + ) + + let writeStdin = vifun3 (fun vthis bytes pos len -> + vint (call Process.write_stdin vthis bytes pos len) + ) +end + +module StdReflect = struct + + let r_get_ = Rope.of_string "get_" + let r_set_ = Rope.of_string "set_" + + let callMethod = vfun3 (fun o f args -> + call_value_on o f (decode_array args) + ) + + let compare = vfun2 (fun a b -> + vint (match compare a b with + | CEq -> 0 + | CInf -> -1 + | CSup -> 1 + | CUndef -> -1) + ) + + let compareMethods = vfun2 (fun a b -> + let rec loop a b = a == b || match a,b with + | VFunction(f1,_),VFunction(f2,_) -> f1 == f2 + | VFieldClosure(v1,f1),VFieldClosure(v2,f2) -> f1 == f2 && EvalMisc.compare v1 v2 = CEq + | _ -> false + in + vbool (loop a b) + ) + + let copy = vfun1 (fun o -> match o with + | VObject o -> VObject { o with ofields = Array.copy o.ofields } + | VInstance vi -> vinstance { + ifields = Array.copy vi.ifields; + iproto = vi.iproto; + ikind = vi.ikind; + } + | VString _ -> o + | VArray va -> VArray { va with avalues = Array.copy va.avalues } + | VVector vv -> VVector (Array.copy vv) + | _ -> unexpected_value o "object" + ) + + let deleteField = vfun2 (fun o name -> + let name = hash (decode_rope name) in + match o with + | VObject o -> + if IntMap.mem name o.oextra then begin + o.oextra <- IntMap.remove name o.oextra; + vtrue + end else if IntMap.mem name o.oproto.pinstance_names then begin + let i = IntMap.find name o.oproto.pinstance_names in + o.oremoved <- IntMap.add name true o.oremoved; + o.ofields.(i) <- vnull; + vtrue + end else + vfalse + | _ -> + vfalse + ) + + let field' = vfun2 (fun o name -> + if o = vnull then vnull else dynamic_field o (hash (decode_rope name)) + ) + + let fields = vfun1 (fun o -> + let proto_fields proto = IntMap.fold (fun name _ acc -> name :: acc) proto.pnames [] in + let fields = match o with + | VObject o -> List.map fst (object_fields o) + | VInstance vi -> IntMap.fold (fun name _ acc -> name :: acc) vi.iproto.pinstance_names [] + | VPrototype proto -> proto_fields proto + | VNull -> [] + | VString _ | VArray _ | VVector _ -> [key_length] + | _ -> unexpected_value o "object" + in + encode_array (List.map (fun i -> encode_rope (rev_hash i)) fields) + ) + + let getProperty = vfun2 (fun o name -> + let name = decode_rope name in + let vget = field o (hash (Rope.concat Rope.empty [r_get_;name])) in + if vget <> VNull then call_value_on o vget [] + else dynamic_field o (hash name) + ) + + let hasField = vfun2 (fun o field -> + let name = hash (decode_rope field) in + let b = match o with + | VObject o -> (IntMap.mem name o.oproto.pinstance_names && not (IntMap.mem name o.oremoved)) || IntMap.mem name o.oextra + | VInstance vi -> IntMap.mem name vi.iproto.pinstance_names || IntMap.mem name vi.iproto.pnames + | VPrototype proto -> IntMap.mem name proto.pnames + | _ -> unexpected_value o "object" + in + vbool b + ) + + let isEnumValue = vfun1 (fun v -> match v with + | VEnumValue _ -> vtrue + | _ -> vfalse + ) + + let isFunction = vfun1 (fun f -> + match f with + | VFunction _ | VFieldClosure _ -> vtrue + | _ -> vfalse + ) + + let isObject = vfun1 (fun v -> match v with + | VObject _ | VString _ | VArray _ | VVector _ | VInstance _ | VPrototype _ -> vtrue + | _ -> vfalse + ) + + let makeVarArgs = vfun1 (fun f -> + vstatic_function (FunN (fun vl -> call_value f [encode_array vl])) + ) + + let setField = vfun3 (fun o name v -> + set_field o (hash (decode_rope name)) v; vnull + ) + + let setProperty = vfun3 (fun o name v -> + let name = decode_rope name in + let vset = field o (hash (Rope.concat Rope.empty [r_set_;name])) in + if vset <> VNull then + call_value_on o vset [v] + else begin + set_field o (hash name) v; + vnull + end + ) +end + +module StdResource = struct + open Common + + let listNames = vfun0 (fun () -> + encode_array (List.map encode_string (hashtbl_keys ((get_ctx()).curapi.MacroApi.get_com()).resources)) + ) + + let getString = vfun1 (fun name -> + try encode_string (Hashtbl.find ((get_ctx()).curapi.MacroApi.get_com()).resources (decode_string name)) with Not_found -> vnull + ) + + let getBytes = vfun1 (fun name -> + try encode_bytes (Bytes.unsafe_of_string (Hashtbl.find ((get_ctx()).curapi.MacroApi.get_com()).resources (decode_string name))) with Not_found -> vnull + ) +end + +module StdSocket = struct + open Unix + + let inet_addr_to_int32 addr = + let s = string_of_inet_addr addr in + match List.map Int32.of_string (ExtString.String.nsplit s ".") with + | [a;b;c;d] -> Int32.add (Int32.add (Int32.add (Int32.shift_left a 24) (Int32.shift_left b 16)) (Int32.shift_left c 8)) d + | _ -> assert false + + let this vthis = match vthis with + | VInstance {ikind = ISocket sock} -> sock + | _ -> unexpected_value vthis "NativeSocket" + + let accept = vifun0 (fun vthis -> + let this = this vthis in + let socket,_ = Unix.accept this in + encode_instance key_sys_net__Socket_NativeSocket ~kind:(ISocket socket) + ) + + let bind = vifun2 (fun vthis host port -> + let this = this vthis in + let host = decode_i32 host in + let port = decode_int port in + (try Unix.bind this (ADDR_INET (StdHost.int32_addr host,port)) with Unix_error _ -> exc_string (Printf.sprintf "Could not bind port %i" port)); + vnull + ) + + let close = vifun0 (fun vthis -> + Unix.close (this vthis); + vnull + ) + + let connect = vifun2 (fun vthis host port -> + let this = this vthis in + let host = decode_i32 host in + let port = decode_int port in + Unix.connect this (ADDR_INET (StdHost.int32_addr host,port)); + vnull + ) + + let host = vifun0 (fun vthis -> + match getsockname (this vthis) with + | ADDR_INET (addr,port) -> + encode_obj None [ + key_ip,vint32 (inet_addr_to_int32 addr); + key_port,vint port; + ] + | _ -> assert false + ) + + let listen = vifun1 (fun vthis connections -> + let this = this vthis in + let connections = decode_int connections in + Unix.listen this connections; + vnull + ) + + let peer = vifun0 (fun vthis -> + match getpeername (this vthis) with + | ADDR_INET (addr,port) -> + encode_obj None [ + key_ip,vint32 (inet_addr_to_int32 addr); + key_port,vint port; + ] + | _ -> assert false + ) + + let receive = vifun3 (fun vthis buf pos len -> + let this = this vthis in + let buf = decode_bytes buf in + let pos = decode_int pos in + let len = decode_int len in + vint (try recv this buf pos len [] with Unix_error(error,msg,_) -> exc_string (Printf.sprintf "%s: %s" msg (error_message error))) + ) + + let receiveChar = vifun0 (fun vthis -> + let buf = Bytes.make 1 '\000' in + ignore(Unix.recv (this vthis) buf 0 1 []); + vint (int_of_char (Bytes.unsafe_get buf 0)) + ) + + let select = vfun4 (fun read write others timeout -> + let proto = get_instance_prototype (get_ctx()) key_sys_net_Socket null_pos in + let i = get_instance_field_index proto key_socket in + let pair = function + | VInstance vi as v -> this vi.iproto.pfields.(i),v + | v -> unexpected_value v "NativeSocket" + in + let read = List.map pair (decode_array read) in + let write = List.map pair (decode_array write) in + let others = List.map pair (decode_array others) in + let timeout = match timeout with VNull -> 0. | VInt32 i -> Int32.to_float i | VFloat f -> f | _ -> unexpected_value timeout "number" in + let read',write',others' = Unix.select (List.map fst read) (List.map fst write) (List.map fst others) timeout in + let read = List.map (fun sock -> List.assq sock read) read' in + let write = List.map (fun sock -> List.assq sock write) write' in + let others = List.map (fun sock -> List.assq sock others) others' in + encode_obj None [ + key_read,encode_array read; + key_write,encode_array write; + key_others,encode_array others; + ] + ) + + let send = vifun3 (fun vthis buf pos len -> + let this = this vthis in + let buf = decode_bytes buf in + let pos = decode_int pos in + let len = decode_int len in + vint (send this buf pos len []) + ) + + let sendChar = vifun1 (fun vthis char -> + let this = this vthis in + let char = decode_int char in + ignore(Unix.send this (Bytes.make 1 (char_of_int char)) 0 1 []); + VNull + ) + + let setFastSend = vifun1 (fun vthis b -> + let this = this vthis in + let b = decode_bool b in + setsockopt this TCP_NODELAY b; + vnull + ) + + let setTimeout = vifun1 (fun vthis timeout -> + let this = this vthis in + let timeout = match timeout with VNull -> 0. | VInt32 i -> Int32.to_float i | VFloat f -> f | _ -> unexpected_value timeout "number" in + setsockopt_float this SO_RCVTIMEO timeout; + setsockopt_float this SO_SNDTIMEO timeout; + vnull + ) + + let shutdown = vifun2 (fun vthis read write -> + let this = this vthis in + let mode = match read,write with + | VTrue,VTrue -> SHUTDOWN_ALL + | VTrue,_ -> SHUTDOWN_RECEIVE + | _,VTrue -> SHUTDOWN_SEND + | _ -> exc_string "Nothing to shut down" + in + Unix.shutdown this mode; + vnull + ) +end + +module StdStd = struct + let parse_float s = + let rec loop sp i = + if i = String.length s then (if sp = 0 then s else String.sub s sp (i - sp)) else + match String.unsafe_get s i with + | ' ' when sp = i -> loop (sp + 1) (i + 1) + | '0'..'9' | '-' | '+' | 'e' | 'E' | '.' -> loop sp (i + 1) + | _ -> String.sub s sp (i - sp) + in + float_of_string (loop 0 0) + + let parse_int s = + let rec loop_hex i = + if i = String.length s then s else + match String.unsafe_get s i with + | '0'..'9' | 'a'..'f' | 'A'..'F' -> loop_hex (i + 1) + | _ -> String.sub s 0 i + in + let rec loop sp i = + if i = String.length s then (if sp = 0 then s else String.sub s sp (i - sp)) else + match String.unsafe_get s i with + | '0'..'9' -> loop sp (i + 1) + | ' ' when sp = i -> loop (sp + 1) (i + 1) + | '-' when i = 0 -> loop sp (i + 1) + | ('x' | 'X') when i = 1 && String.get s 0 = '0' -> loop_hex (i + 1) + | _ -> String.sub s sp (i - sp) + in + Int32.of_string (loop 0 0) + + let is' = vfun2 (fun v t -> match t with + | VNull -> vfalse + | VPrototype proto -> vbool (is v proto.ppath) + | _ -> vfalse + ) + + let instance = vfun2 (fun v t -> match t with + | VPrototype proto -> + if is v proto.ppath then v else vnull + | _ -> vfalse + ) + + let string = vfun1 (fun v -> + encode_rope (s_value 0 v) + ) + + let int = vfun1 (fun v -> + try vint (int_of_float (num v)) with _ -> vnull + ) + + let parseInt = vfun1 (fun v -> + try vint32 (parse_int (decode_string v)) with _ -> vnull + ) + + let parseFloat = vfun1 (fun v -> + try vfloat (parse_float (decode_string v)) with _ -> vnull + ) + + let random = vfun1 (fun v -> + let v = decode_int v in + vint (Random.State.int random (if v <= 0 then 1 else v)) + ); +end + +module StdString = struct + let this vthis = match vthis with + | VString(r,_) -> r + | v -> unexpected_value v "string" + + let this_pair vthis = match vthis with + | VString(r,s) -> r,Lazy.force s + | v -> unexpected_value v "string" + + let this_string vthis = match vthis with + | VString(_,s) -> Lazy.force s + | v -> unexpected_value v "string" + + let charAt = vifun1 (fun vthis index -> + let this = this_string vthis in + let i = decode_int index in + if i < 0 || i >= String.length this then encode_rope Rope.empty + else encode_rope (Rope.of_char (String.get this i)) + ) + + let charCodeAt = vifun1 (fun vthis index -> + let this = this_string vthis in + let i = decode_int index in + if i < 0 || i >= String.length this then vnull + else vint (int_of_char (String.get this i)) + ) + + let fromCharCode = vfun1 (fun i -> + let i = decode_int i in + if i < 0 || i > 0xFF then vnull + else encode_rope (Rope.of_char (char_of_int i)) + ) + + let indexOf = vifun2 (fun vthis str startIndex -> + let this = this vthis in + let str = decode_string str in + let i = default_int startIndex 0 in + try + vint (Rope.search_forward_string str this i) + with Not_found -> + vint (-1) + ) + + let lastIndexOf = vifun2 (fun vthis str startIndex -> + let this = this_string vthis in + let str = decode_string str in + let i = default_int startIndex (String.length this - 1) in + try + if i >= String.length this || i < 0 then raise Not_found; + vint (Str.search_backward (Str.regexp_string str) this i) + with Not_found -> + vint (-1) + ) + + let split = vifun1 (fun vthis delimiter -> + let this,s = this_pair vthis in + let delimiter = decode_string delimiter in + let l_delimiter = String.length delimiter in + let l_this = Rope.length this in + if l_delimiter = 0 then + encode_array (List.map (fun chr -> encode_string (String.make 1 chr)) (ExtString.String.explode s)) + else if l_delimiter > l_this then + encode_array [encode_rope this] + else begin + let chr = delimiter.[0] in + let acc = DynArray.create () in + let rec loop k i = + try + if i > l_this - l_delimiter then raise Not_found; + let index = String.index_from s i chr in + let rec loop2 i2 = + if i2 = l_delimiter then true + else if String.unsafe_get s (index + i2) = String.unsafe_get delimiter i2 then loop2 (i2 + 1) + else false + in + if not (loop2 1) then + loop k (index + 1) + else begin + DynArray.add acc (encode_rope (Rope.sub this k (index - k))); + loop (index + l_delimiter) (index + l_delimiter) + end + with Not_found -> + DynArray.add acc (encode_rope (Rope.sub this k (l_this - k))) + in + let rec loop1 i = + try + if i = l_this then raise Not_found; + let index = String.index_from s i chr in + DynArray.add acc (encode_rope (Rope.sub this i (index - i))); + loop1 (index + l_delimiter) + with Not_found -> + DynArray.add acc (encode_rope (Rope.sub this i (l_this - i))) + in + if l_delimiter = 1 then loop1 0 else loop 0 0; + encode_array_instance (EvalArray.create (DynArray.to_array acc)) + end + ) + + let substr = vifun2 (fun vthis pos len -> + let this = this vthis in + let pos = decode_int pos in + if pos >= Rope.length this then + encode_rope Rope.empty + else begin + let pos = if pos < 0 then begin + let pos = Rope.length this + pos in + if pos < 0 then 0 else pos + end else pos in + let len = default_int len (Rope.length this - pos) in + let len = if len < 0 then Rope.length this + len - pos else len in + let s = + if len < 0 then Rope.empty + else if len + pos > Rope.length this then Rope.sub this pos (Rope.length this - pos) + else Rope.sub this pos len + in + encode_rope s + end + ) + + let substring = vifun2 (fun vthis startIndex endIndex -> + let this = this vthis in + let first = decode_int startIndex in + let l = Rope.length this in + let last = default_int endIndex l in + let first = if first < 0 then 0 else first in + let last = if last < 0 then 0 else last in + let first,last = if first > last then last,first else first,last in + let last = if last > l then l else last in + let s = if first > l then + Rope.empty + else + Rope.sub this first (last - first) + in + encode_rope s + ) + + let toLowerCase = vifun0 (fun vthis -> encode_rope (Rope.lowercase (this vthis))) + + let toString = vifun0 (fun vthis -> vthis) + + let toUpperCase = vifun0 (fun vthis -> encode_rope (Rope.uppercase (this vthis))) + + let cca = vifun1 (fun vthis i -> + let this = this_string vthis in + let i = decode_int i in + if i < 0 || i >= String.length this then vnull + else vint (int_of_char (String.unsafe_get this i)) + ) +end + +module StdStringBuf = struct + module Buffer = Rope.Buffer + + let this vthis = match vthis with + | VInstance {ikind = IBuffer buf} -> buf + | v -> unexpected_value v "string" + + let add = vifun1 (fun vthis x -> + let this = this vthis in + begin match x with + | VString(s,_) -> Buffer.add_rope this s + | _ -> Buffer.add_string this (value_string x) + end; + vnull; + ) + + let addChar = vifun1 (fun vthis c -> + let this = this vthis in + let c = decode_int c in + let c = try char_of_int c with _ -> exc_string "char_of_int" in + Buffer.add_char this c; + vnull + ) + + let addSub = vifun3 (fun vthis s pos len -> + let this = this vthis in + let s = decode_rope s in + let i = decode_int pos in + let len = match len with + | VNull -> Rope.length s - i + | VInt32 i -> Int32.to_int i + | _ -> unexpected_value len "int" + in + Buffer.add_rope this (Rope.sub s i len); + vnull + ) + + let get_length = vifun0 (fun vthis -> + let this = this vthis in + vint (Buffer.length this) + ) + + let toString = vifun0 (fun vthis -> + encode_rope (Buffer.contents (this vthis)) + ) +end + +module StdStringTools = struct + let url_encode s = + let b = Rope.Buffer.create 0 in + let hex = "0123456789ABCDEF" in + for i = 0 to String.length s - 1 do + let c = String.unsafe_get s i in + match c with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '-' | '.' -> + Rope.Buffer.add_char b c + | _ -> + Rope.Buffer.add_char b '%'; + Rope.Buffer.add_char b (String.unsafe_get hex (int_of_char c lsr 4)); + Rope.Buffer.add_char b (String.unsafe_get hex (int_of_char c land 0xF)); + done; + Rope.Buffer.contents b + + let fastCodeAt = vfun2 (fun s index -> + let s = decode_string s in + let index = decode_int index in + if index >= String.length s then vnull + else vint (int_of_char s.[index]) + ) + + let urlEncode = vfun1 (fun s -> + let s = decode_string s in + encode_rope (url_encode s) + ) + + let urlDecode = vfun1 (fun s -> + let s = decode_string s in + let b = Rope.Buffer.create 0 in + let len = String.length s in + let decode c = + match c with + | '0'..'9' -> Some (int_of_char c - int_of_char '0') + | 'a'..'f' -> Some (int_of_char c - int_of_char 'a' + 10) + | 'A'..'F' -> Some (int_of_char c - int_of_char 'A' + 10) + | _ -> None + in + let rec loop i = + if i = len then () else + let c = String.unsafe_get s i in + match c with + | '%' -> + let p1 = (try decode (String.get s (i + 1)) with _ -> None) in + let p2 = (try decode (String.get s (i + 2)) with _ -> None) in + (match p1, p2 with + | Some c1, Some c2 -> + Rope.Buffer.add_char b (char_of_int ((c1 lsl 4) lor c2)); + loop (i + 3) + | _ -> + loop (i + 1)); + | '+' -> + Rope.Buffer.add_char b ' '; + loop (i + 1) + | c -> + Rope.Buffer.add_char b c; + loop (i + 1) + in + loop 0; + encode_rope (Rope.Buffer.contents b) + ) +end + +module StdSys = struct + open MacroApi + open Common + + let args = vfun0 (fun () -> + encode_array (List.map encode_string ((get_ctx()).curapi.MacroApi.get_com()).sys_args) + ) + + let _command = vfun1 (fun cmd -> + let cmd = decode_string cmd in + vint (((get_ctx()).curapi.get_com()).run_command cmd) + ) + + let cpuTime = vfun0 (fun () -> vfloat (Sys.time())) + + let environment = vfun0 (fun () -> + let env = Unix.environment() in + let h = StringHashtbl.create 0 in + Array.iter(fun s -> + let k, v = ExtString.String.split s "=" in + StringHashtbl.replace h (Rope.of_string k,lazy k) (encode_string v) + ) env; + encode_string_map_direct h + ) + + let exit = vfun1 (fun code -> + (* TODO: Borrowed from interp.ml *) + if (get_ctx()).curapi.use_cache() then raise (Error.Fatal_error ("",Globals.null_pos)); + raise (Interp.Sys_exit(decode_int code)); + ) + + let getChar = vfun1 (fun echo -> + let echo = decode_bool echo in + vint (Extc.getch echo) + ) + + let getCwd = vfun0 (fun () -> + let dir = Unix.getcwd() in + let l = String.length dir in + encode_string (if l = 0 then "./" else match dir.[l - 1] with '/' | '\\' -> dir | _ -> dir ^ "/") + ) + + let getEnv = vfun1 (fun s -> + let s = decode_string s in + try encode_string (Unix.getenv s) with _ -> vnull + ) + + let print = vfun1 (fun v -> + let ctx = get_ctx() in + let com = ctx.curapi.get_com() in + com.print (value_string v); + vnull + ) + + let println = vfun1 (fun v -> + let ctx = get_ctx() in + let com = ctx.curapi.get_com() in + com.print (value_string v ^ "\n"); + vnull + ) + + let programPath = vfun0 (fun () -> + let ctx = get_ctx() in + let com = ctx.curapi.get_com() in + match com.main_class with + | None -> assert false + | Some p -> + match ctx.curapi.get_type (s_type_path p) with + | Some(Type.TInst (c, _)) -> encode_string (Extc.get_full_path c.Type.cl_pos.Globals.pfile) + | _ -> assert false + ) + + let putEnv = vfun2 (fun s v -> + let s = decode_string s in + let v = decode_string v in + Unix.putenv s v; + vnull + ) + + let setCwd = vfun1 (fun s -> + Unix.chdir (decode_string s); + vnull + ) + + let setTimeLocale = vfun1 (fun _ -> vfalse) + + let sleep = vfun1 (fun f -> ignore(Unix.select [] [] [] (decode_float f)); vnull) + + let stderr = vfun0 (fun () -> + encode_instance key_sys_io_FileOutput ~kind:(IOutChannel stderr) + ) + + let stdin = vfun0 (fun () -> + encode_instance key_sys_io_FileInput ~kind:(IInChannel(stdin,ref false)) + ) + + let stdout = vfun0 (fun () -> + encode_instance key_sys_io_FileOutput ~kind:(IOutChannel stdout) + ) + + let systemName = + let cached_sys_name = ref None in + vfun0 (fun () -> + let s = match Sys.os_type with + | "Unix" -> + (match !cached_sys_name with + | Some n -> n + | None -> + let ic = Unix.open_process_in "uname" in + let uname = (match input_line ic with + | "Darwin" -> "Mac" + | n -> n + ) in + close_in ic; + cached_sys_name := Some uname; + uname) + | "Win32" | "Cygwin" -> "Windows" + | s -> s + in + encode_string s + ) + + let time = vfun0 (fun () -> vfloat (Unix.gettimeofday())) +end + +module StdType = struct + open Ast + + let create_enum v constr params = + let vf = field v constr in + match vf,params with + | VEnumValue _,VNull -> vf + | VEnumValue _,VArray va when va.alength = 0 -> vf + | VFunction _,VArray va -> call_value vf (EvalArray.to_list va) + | _ -> unexpected_value params "array" + + let allEnums = vfun1 (fun v -> + match v with + | VPrototype ({pkind = PEnum names} as proto) -> + begin try + let l = ExtList.List.filter_map (fun s -> + try + begin match proto_field_direct proto (hash_s s) with + | VEnumValue _ as v -> Some v + | _ -> None + end + with Not_found -> + None + ) names in + encode_array l + with Not_found -> + vnull + end + | _ -> + vnull + ) + + let createEmptyInstance = vfun1 (fun v -> + match v with + | VPrototype {pkind = PClass _; ppath = path} -> + begin try + (Hashtbl.find (get_ctx()).builtins.empty_constructor_builtins path) () + with Not_found -> + encode_instance path + end + | _ -> vnull + ) + + let createEnum = vfun3 (fun e constr params -> + let constr = hash (decode_rope constr) in + create_enum e constr params + ) + + let createEnumIndex = vfun3 (fun e index params -> + let index = decode_int index in + match e with + | VPrototype {pkind = PEnum names} -> + begin try + create_enum e (hash_s (List.nth names index)) params + with Not_found -> + vnull + end + | _ -> + vnull + ) + + let createInstance = vfun2 (fun v vl -> + match v with + | VPrototype {pkind = PClass _; ppath = path} -> + let ctx = get_ctx() in + begin try + let f = get_special_instance_constructor_raise ctx path in + f (decode_array vl) + with Not_found -> + let vthis = encode_instance path in + let fnew = get_instance_constructor ctx path null_pos in + ignore(call_value_on vthis (Lazy.force fnew) (decode_array vl)); + vthis + end + | _ -> + unexpected_value v "Class" + ) + + let enumConstructor = vfun1 (fun v -> match v with + | VEnumValue ve -> + begin try + begin match (get_static_prototype_raise (get_ctx()) ve.epath).pkind with + | PEnum names -> encode_string (List.nth names ve.eindex) + | _ -> raise Not_found + end + with Not_found -> + vnull + end + | v -> unexpected_value v "enum value" + ) + + let enumEq = vfun2 (fun a b -> + vbool (equals_structurally a b) + ) + + let enumIndex = vfun1 (fun v -> match v with + | VEnumValue ev -> (try vint32 (Int32.of_int ev.eindex) with Not_found -> vnull) + | v -> unexpected_value v "enum value" + ) + + let enumParameters = vfun1 (fun v -> match v with + | VEnumValue ev -> + let va = EvalArray.create ev.eargs in + VArray va + | v -> unexpected_value v "enum value" + ) + + let getClass = vfun1 (fun v -> + match v with + | VInstance ({iproto = {pkind = PInstance}} as vi) -> get_static_prototype_as_value (get_ctx()) vi.iproto.ppath null_pos + | VString _ -> get_static_prototype_as_value (get_ctx()) key_String null_pos + | VArray _ -> get_static_prototype_as_value (get_ctx()) key_Array null_pos + | VVector _ -> get_static_prototype_as_value (get_ctx()) key_eval_Vector null_pos + | _ -> vnull + ) + + let getClassFields = vfun1 (fun v -> + match v with + | VPrototype {pkind = PClass _;pnames = names} -> + encode_array (IntMap.fold (fun name _ acc -> (encode_rope (rev_hash name)) :: acc) names []); + | _ -> + vnull + ) + + let getClassName = vfun1 (fun v -> + match v with + | VPrototype {pkind = PClass _; ppath = path} -> encode_rope (rev_hash path) + | _ -> vnull + ) + + let getEnum = vfun1 (fun v -> + match v with + | VEnumValue ve -> get_static_prototype_as_value (get_ctx()) ve.epath null_pos + | _ -> vnull + ) + + let getEnumConstructs = vfun1 (fun v -> + match v with + | VPrototype {pkind = PEnum names} -> + begin try + encode_array (List.map encode_string names) + with Not_found -> + vnull + end + | _ -> + vnull + ) + + let getEnumName = vfun1 (fun v -> + match v with + | VPrototype {pkind = PEnum _; ppath = path} -> encode_rope (rev_hash path) + | _ -> vnull + ) + + let getInstanceFields = vfun1 (fun v -> + match v with + | VPrototype proto -> + begin try + let rec loop acc proto = + let acc = match proto.pparent with + | None -> acc + | Some proto -> loop acc proto + in + let acc = IntMap.fold (fun name _ acc -> IntMap.add name 0 acc) proto.pinstance_names acc in + IntMap.fold (fun name _ acc -> IntMap.add name 0 acc) proto.pnames acc + in + let proto = get_instance_prototype (get_ctx()) proto.ppath null_pos in + encode_array (List.map (fun i -> encode_rope (rev_hash i)) (ptmap_keys (loop IntMap.empty proto))) + with Not_found -> + vnull + end + | _ -> + vnull + ) + + let getSuperClass = vfun1 (fun v -> + match v with + | VPrototype {pkind = PClass _; pparent = Some proto} -> proto.pvalue + | _ -> vnull + ) + + let resolveClass = vfun1 (fun v -> + let name = decode_rope v in + try (get_static_prototype_raise (get_ctx()) (hash name)).pvalue with Not_found -> vnull + ) + + let resolveEnum = vfun1 (fun v -> + let name = decode_rope v in + try + let proto = get_static_prototype_raise (get_ctx()) (hash name) in + begin match proto.pkind with + | PEnum _ -> proto.pvalue + | _ -> vnull + end + with Not_found -> + vnull + ) + + let typeof = vfun1 (fun v -> + let ctx = (get_ctx()) in + let i,vl = match v with + | VNull -> 0,[||] + | VInt32 _ -> 1,[||] + | VFloat _ -> 2,[||] + | VTrue | VFalse -> 3,[||] + | VInstance vi -> 6,[|get_static_prototype_as_value ctx vi.iproto.ppath null_pos|] + | VString _ -> 6,[|get_static_prototype_as_value ctx key_String null_pos|] + | VArray _ -> 6,[|get_static_prototype_as_value ctx key_Array null_pos|] + | VVector _ -> 6,[|get_static_prototype_as_value ctx key_eval_Vector null_pos|] + | VObject _ | VPrototype _ -> + 4,[||] + | VFunction _ + | VFieldClosure _ -> + 5,[||] + | VEnumValue ve -> + 7,[|get_static_prototype_as_value ctx ve.epath null_pos|] + in + encode_enum_value key_ValueType i vl None + ) +end + +module StdUncompress = struct + open Extc + + let this vthis = match vthis with + | VInstance {ikind = IZip zip} -> zip + | _ -> unexpected_value vthis "Uncompress" + + let close = vifun0 (fun vthis -> + zlib_inflate_end (this vthis).z; + vnull + ) + + let execute = vifun4 (fun vthis src srcPos dst dstPos -> + StdCompress.exec zlib_inflate vthis src srcPos dst dstPos + ) + + let run = vfun2 (fun src bufsize -> + let src = decode_bytes src in + let bufsize = default_int bufsize (1 lsl 16) in + let zip = zlib_inflate_init () in + let buf = Buffer.create 0 in + let tmp = Bytes.make bufsize (char_of_int 0) in + let rec loop pos = + let r = zlib_inflate zip (Bytes.unsafe_to_string src) pos (Bytes.length src - pos) tmp 0 bufsize Z_SYNC_FLUSH in + Buffer.add_subbytes buf tmp 0 r.z_wrote; + if not r.z_finish then loop (pos + r.z_read) + in + loop 0; + encode_bytes (Bytes.unsafe_of_string (Buffer.contents buf)) + ) + + let setFlushMode = StdCompress.setFlushMode +end + +module StdUtf8 = struct + let this vthis = match vthis with + | VInstance {ikind = IUtf8 buf} -> buf + | v -> unexpected_value v "string" + + let addChar = vifun1 (fun vthis c -> + UTF8.Buf.add_char (this vthis) (UChar.uchar_of_int (decode_int c)); + vnull + ) + + let charCodeAt = vfun2 (fun s index -> + let s = decode_string s in + let i = decode_int index in + let c = try UTF8.get s i with exc -> exc_string (Printexc.to_string exc) in + vint (UChar.int_of_uchar c) + ) + + let compare = vfun2 (fun a b -> + let a = decode_string a in + let b = decode_string b in + vint (UTF8.compare a b) + ) + + let decode = vfun1 (fun s -> + let s = decode_string s in + let buf = Bytes.create (UTF8.length s) in + let i = ref 0 in + UTF8.iter (fun uc -> + Bytes.unsafe_set buf !i (UChar.char_of uc); + incr i + ) s; + encode_string (Bytes.unsafe_to_string buf) + ) + + let encode = vfun1 (fun s -> + let s = decode_string s in + encode_string (UTF8.init (String.length s) (fun i -> UChar.of_char s.[i])) + ) + + let iter = vfun2 (fun s f -> + let s = decode_string s in + UTF8.iter (fun uc -> ignore(call_value f [vint (UChar.int_of_uchar uc)])) s; + vnull + ) + + let length = vfun1 (fun s -> + let s = decode_string s in + vint (UTF8.length s) + ) + + let sub = vfun3 (fun s pos len -> + let s = decode_string s in + let pos = decode_int pos in + let len = decode_int len in + let buf = UTF8.Buf.create 0 in + let i = ref (-1) in + UTF8.iter (fun c -> + incr i; + if !i >= pos && !i < pos + len then UTF8.Buf.add_char buf c; + ) s; + encode_string (UTF8.Buf.contents buf) + ) + + let toString = vifun0 (fun vthis -> + encode_string (UTF8.Buf.contents (this vthis)) + ) + + let validate = vfun1 (fun s -> + let s = decode_string s in + try + UTF8.validate s; + vtrue + with UTF8.Malformed_code -> + vfalse + ) +end + +let init_fields builtins path static_fields instance_fields = + let map (name,v) = (hash_s name,v) in + let path = path_hash path in + builtins.static_builtins <- IntMap.add path (List.map map static_fields) builtins.static_builtins; + builtins.instance_builtins <- IntMap.add path (List.map map instance_fields) builtins.instance_builtins + +let init_maps builtins = + let this vthis = match vthis with + | VInstance {ikind = IIntMap h} -> h + | v -> unexpected_value v "int map" + in + init_fields builtins (["haxe";"ds"],"IntMap") [] (StdIntMap.map_fields vint decode_int (fun i -> Rope.of_string (string_of_int i)) this); + let this vthis = match vthis with + | VInstance {ikind = IStringMap h} -> h + | v -> unexpected_value v "string map" + in + init_fields builtins (["haxe";"ds"],"StringMap") [] (StdStringMap.map_fields vstring_direct decode_rope_string (fun (r,_) -> r) this); + let this vthis = match vthis with + | VInstance {ikind = IObjectMap h} -> Obj.magic h + | v -> unexpected_value v "object map" + in + init_fields builtins (["haxe";"ds"],"ObjectMap") [] (StdObjectMap.map_fields (fun v -> v) (fun v -> v) (fun s -> s_value 0 s) this) + +let init_constructors builtins = + let add = Hashtbl.add builtins.constructor_builtins in + add key_Array (fun _ -> encode_array_instance (EvalArray.create [||])); + add key_eval_Vector + (fun vl -> + match vl with + | [size] -> + encode_vector_instance (Array.make (decode_int size) vnull) + | _ -> assert false + ); + add key_Date + (fun vl -> + begin match List.map decode_int vl with + | [y;m;d;h;mi;s] -> + let open Unix in + let t = localtime 0. in + let f = mktime {t with tm_sec=s;tm_min=mi;tm_hour=h;tm_mday=d;tm_mon=m;tm_year=y - 1900} in + encode_instance key_Date ~kind:(IDate (fst f)) + | _ -> assert false + end + ); + add key_EReg + (fun vl -> match vl with + | [r;opt] -> encode_instance key_EReg ~kind:(StdEReg.create (decode_string r) (decode_string opt)) + | _ -> assert false + ); + add key_String + (fun vl -> match vl with + | [s] -> s + | _ -> assert false + ); + add key_StringBuf (fun _ -> encode_instance key_StringBuf ~kind:(IBuffer (Rope.Buffer.create 0))); + add key_haxe_Utf8 + (fun vl -> match vl with + | [size] -> encode_instance key_haxe_Utf8 ~kind:(IUtf8 (UTF8.Buf.create (default_int size 0))) + | _ -> assert false + ); + add key_haxe_ds_StringMap (fun _ -> encode_instance key_haxe_ds_StringMap ~kind:(IStringMap (StringHashtbl.create 0))); + add key_haxe_ds_IntMap (fun _ -> encode_instance key_haxe_ds_IntMap ~kind:(IIntMap (IntHashtbl.create 0))); + add key_haxe_ds_ObjectMap (fun _ -> encode_instance key_haxe_ds_ObjectMap ~kind:(IObjectMap (Obj.magic (ValueHashtbl.create 0)))); + add key_haxe_io_BytesBuffer (fun _ -> encode_instance key_haxe_io_BytesBuffer ~kind:(IOutput (Buffer.create 0))); + add key_sys_io__Process_NativeProcess + (fun vl -> match vl with + | [cmd;args] -> + let cmd = decode_string cmd in + let args = match args with + | VNull -> None + | VArray va -> Some (Array.map decode_string va.avalues) + | _ -> unexpected_value args "array" + in + encode_instance key_sys_io__Process_NativeProcess ~kind:(IProcess (Process.run cmd args)) + | _ -> assert false + ); + add key_sys_net__Socket_NativeSocket + (fun _ -> + encode_instance key_sys_net__Socket_NativeSocket ~kind:(ISocket ((Unix.socket Unix.PF_INET Unix.SOCK_STREAM) 0)) + ); + add key_haxe_zip_Compress + (fun vl -> match vl with + | [level] -> + let level = decode_int level in + let z = Extc.zlib_deflate_init level in + encode_instance key_haxe_zip_Compress ~kind:(IZip { z = z; z_flush = Extc.Z_NO_FLUSH }) + | _ -> assert false + ); + add key_haxe_zip_Uncompress + (fun vl -> match vl with + | [windowBits] -> + let windowBits = default_int windowBits 15 in + let z = Extc.zlib_inflate_init2 windowBits in + encode_instance key_haxe_zip_Uncompress ~kind:(IZip { z = z; z_flush = Extc.Z_NO_FLUSH }) + | _ -> assert false + ) + +let init_empty_constructors builtins = + let h = builtins.empty_constructor_builtins in + Hashtbl.add h key_Array (fun () -> encode_array_instance (EvalArray.create [||])); + Hashtbl.add h key_eval_Vector (fun () -> encode_vector_instance (Array.create 0 vnull)); + Hashtbl.add h key_Date (fun () -> encode_instance key_Date ~kind:(IDate 0.)); + Hashtbl.add h key_EReg (fun () -> encode_instance key_EReg ~kind:(IRegex {r = Pcre.regexp ""; r_global = false; r_string = ""; r_groups = [||]})); + Hashtbl.add h key_String (fun () -> encode_rope Rope.empty); + Hashtbl.add h key_haxe_Utf8 (fun () -> encode_instance key_haxe_Utf8 ~kind:(IUtf8 (UTF8.Buf.create 0))); + Hashtbl.add h key_haxe_ds_StringMap (fun () -> encode_instance key_haxe_ds_StringMap ~kind:(IStringMap (StringHashtbl.create 0))); + Hashtbl.add h key_haxe_ds_IntMap (fun () -> encode_instance key_haxe_ds_IntMap ~kind:(IIntMap (IntHashtbl.create 0))); + Hashtbl.add h key_haxe_ds_ObjectMap (fun () -> encode_instance key_haxe_ds_ObjectMap ~kind:(IObjectMap (Obj.magic (ValueHashtbl.create 0)))); + Hashtbl.add h key_haxe_io_BytesBuffer (fun () -> encode_instance key_haxe_io_BytesBuffer ~kind:(IOutput (Buffer.create 0))) + +let init_standard_library builtins = + init_constructors builtins; + init_empty_constructors builtins; + init_maps builtins; + init_fields builtins ([],"Array") [] [ + "concat",StdArray.concat; + "copy",StdArray.copy; + "filter",StdArray.filter; + "indexOf",StdArray.indexOf; + "insert",StdArray.insert; + "iterator",StdArray.iterator; + "join",StdArray.join; + "lastIndexOf",StdArray.lastIndexOf; + "map",StdArray.map; + "pop",StdArray.pop; + "push",StdArray.push; + "remove",StdArray.remove; + "reverse",StdArray.reverse; + "shift",StdArray.shift; + "slice",StdArray.slice; + "sort",StdArray.sort; + "splice",StdArray.splice; + "toString",StdArray.toString; + "unshift",StdArray.unshift; + ]; + init_fields builtins (["eval"],"Vector") [ + "fromArrayCopy",StdEvalVector.fromArrayCopy; + ] [ + "blit",StdEvalVector.blit; + "toArray",StdEvalVector.toArray; + "copy",StdEvalVector.copy; + "join",StdEvalVector.join; + "map",StdEvalVector.map; + ]; + init_fields builtins (["haxe";"io"],"Bytes") [ + "alloc",StdBytes.alloc; + "fastGet",StdBytes.fastGet; + "ofData",StdBytes.ofData; + "ofString",StdBytes.ofString; + ] [ + "blit",StdBytes.blit; + "compare",StdBytes.compare; + "fill",StdBytes.fill; + "get",StdBytes.get; + "getData",StdBytes.getData; + "getDouble",StdBytes.getDouble; + "getFloat",StdBytes.getFloat; + "getInt32",StdBytes.getInt32; + "getInt64",StdBytes.getInt64; + "getString",StdBytes.getString; + "getUInt16",StdBytes.getUInt16; + "set",StdBytes.set; + "setDouble",StdBytes.setDouble; + "setFloat",StdBytes.setFloat; + "setInt32",StdBytes.setInt32; + "setInt64",StdBytes.setInt64; + "setUInt16",StdBytes.setUInt16; + "sub",StdBytes.sub; + "toHex",StdBytes.toHex; + "toString",StdBytes.toString; + ]; + init_fields builtins (["haxe";"io"],"BytesBuffer") [] [ + "get_length",StdBytesBuffer.get_length; + "addByte",StdBytesBuffer.addByte; + "add",StdBytesBuffer.add; + "addString",StdBytesBuffer.addString; + "addInt32",StdBytesBuffer.addInt32; + "addInt64",StdBytesBuffer.addInt64; + "addFloat",StdBytesBuffer.addFloat; + "addDouble",StdBytesBuffer.addDouble; + "addBytes",StdBytesBuffer.addBytes; + "getBytes",StdBytesBuffer.getBytes; + ]; + init_fields builtins (["haxe"],"CallStack") [ + "getCallStack",StdCallStack.getCallStack; + "getExceptionStack",StdCallStack.getExceptionStack; + ] []; + init_fields builtins (["haxe";"zip"],"Compress") [ + "run",StdCompress.run; + ] [ + "close",StdCompress.close; + "execute",StdCompress.execute; + "setFlushMode",StdCompress.setFlushMode; + ]; + init_fields builtins (["eval";"vm"],"Context") [ + "addBreakpoint",StdContext.addBreakpoint; + "breakHere",StdContext.breakHere; + "callMacroApi",StdContext.callMacroApi; + "loadPlugin",StdContext.loadPlugin; + ] []; + init_fields builtins (["haxe";"crypto"],"Crc32") [ + "make",StdCrc32.make; + ] []; + init_fields builtins ([],"Date") [ + "fromString",StdDate.fromString; + "fromTime",StdDate.fromTime; + "now",StdDate.now; + ] [ + "getDate",StdDate.getDate; + "getDay",StdDate.getDay; + "getFullYear",StdDate.getFullYear; + "getHours",StdDate.getHours; + "getMinutes",StdDate.getMinutes; + "getMonth",StdDate.getMonth; + "getSeconds",StdDate.getSeconds; + "getTime",StdDate.getTime; + "toString",StdDate.toString; + ]; + init_fields builtins ([],"EReg") [ + "escape",StdEReg.escape; + ] [ + "map",StdEReg.map; + "match",StdEReg.match'; + "matched",StdEReg.matched; + "matchedLeft",StdEReg.matchedLeft; + "matchedPos",StdEReg.matchedPos; + "matchedRight",StdEReg.matchedRight; + "matchSub",StdEReg.matchSub; + "replace",StdEReg.replace; + "split",StdEReg.split; + ]; + init_fields builtins (["sys";"io"],"File") [ + "append",StdFile.append; + "getBytes",StdFile.getBytes; + "getContent",StdFile.getContent; + "read",StdFile.read; + "saveBytes",StdFile.saveBytes; + "saveContent",StdFile.saveContent; + "write",StdFile.write; + ] []; + init_fields builtins (["sys";"io"],"FileInput") [] [ + "close",StdFileInput.close; + "eof",StdFileInput.eof; + "seek",StdFileInput.seek; + "tell",StdFileInput.tell; + "readByte",StdFileInput.readByte; + "readBytes",StdFileInput.readBytes; + ]; + init_fields builtins (["sys";"io"],"FileOutput") [] [ + "close",StdFileOutput.close; + "flush",StdFileOutput.flush; + "seek",StdFileOutput.seek; + "tell",StdFileOutput.tell; + "writeByte",StdFileOutput.writeByte; + "writeBytes",StdFileOutput.writeBytes; + ]; + init_fields builtins (["haxe";"io"],"FPHelper") [ + "doubleToI64",StdFPHelper.doubleToI64; + "floatToI32",StdFPHelper.floatToI32; + "i32ToFloat",StdFPHelper.i32ToFloat; + "i64ToDouble",StdFPHelper.i64ToDouble; + ] []; + init_fields builtins (["sys"],"FileSystem") [ + "absolutePath",StdFileSystem.absolutePath; + "createDirectory",StdFileSystem.createDirectory; + "deleteFile",StdFileSystem.deleteFile; + "deleteDirectory",StdFileSystem.deleteDirectory; + "exists",StdFileSystem.exists; + "fullPath",StdFileSystem.fullPath; + "isDirectory",StdFileSystem.isDirectory; + "rename",StdFileSystem.rename; + "readDirectory",StdFileSystem.readDirectory; + "stat",StdFileSystem.stat; + ] []; + init_fields builtins (["eval";"vm"],"Gc") [ + "allocated_bytes",StdGc.allocated_bytes; + "compact",StdGc.compact; + "counters",StdGc.counters; + "finalise",StdGc.finalise; + "finalise_release",StdGc.finalise_release; + "full_major",StdGc.full_major; + "get",StdGc.get; + "major",StdGc.major; + "major_slice",StdGc.major_slice; + "minor",StdGc.minor; + "print_stat",StdGc.print_stat; + "quick_stat",StdGc.quick_stat; + "set",StdGc.set; + "stat",StdGc.stat; + ] []; + init_fields builtins (["sys";"net"],"Host") [ + "localhost",StdHost.localhost; + "hostReverse",StdHost.hostReverse; + "hostToString",StdHost.hostToString; + "resolve",StdHost.resolve; + ] []; + init_fields builtins (["haxe"],"Log") [ + "trace",StdLog.trace; + ] []; + init_fields builtins ([],"Math") [ + "NaN",StdMath.nan; + "NEGATIVE_INFINITY",StdMath.negative_infinity; + "PI",StdMath.pi; + "POSITIVE_INFINITY",StdMath.positive_infinity; + "abs",StdMath.abs; + "acos",StdMath.acos; + "asin",StdMath.asin; + "atan",StdMath.atan; + "atan2",StdMath.atan2; + "ceil",StdMath.ceil; + "cos",StdMath.cos; + "exp",StdMath.exp; + "fceil",StdMath.fceil; + "ffloor",StdMath.ffloor; + "floor",StdMath.floor; + "fround",StdMath.fround; + "isFinite",StdMath.isFinite; + "isNaN",StdMath.isNaN; + "log",StdMath.log; + "max",StdMath.max; + "min",StdMath.min; + "pow",StdMath.pow; + "random",StdMath.random; + "round",StdMath.round; + "sin",StdMath.sin; + "sqrt",StdMath.sqrt; + "tan",StdMath.tan; + ] []; + init_fields builtins (["haxe";"crypto"],"Md5") [ + "encode",StdMd5.encode; + "make",StdMd5.make; + ] []; + init_fields builtins (["sys";"io";"_Process"],"NativeProcess") [ ] [ + "close",StdNativeProcess.close; + "exitCode",StdNativeProcess.exitCode; + "getPid",StdNativeProcess.getPid; + "kill",StdNativeProcess.kill; + "readStderr",StdNativeProcess.readStderr; + "readStdout",StdNativeProcess.readStdout; + "closeStdin",StdNativeProcess.closeStdin; + "writeStdin",StdNativeProcess.writeStdin; + ]; + init_fields builtins ([],"Reflect") [ + "callMethod",StdReflect.callMethod; + "compare",StdReflect.compare; + "compareMethods",StdReflect.compareMethods; + "copy",StdReflect.copy; + "deleteField",StdReflect.deleteField; + "field",StdReflect.field'; + "fields",StdReflect.fields; + "getProperty",StdReflect.getProperty; + "hasField",StdReflect.hasField; + "isEnumValue",StdReflect.isEnumValue; + "isFunction",StdReflect.isFunction; + "isObject",StdReflect.isObject; + "makeVarArgs",StdReflect.makeVarArgs; + "setField",StdReflect.setField; + "setProperty",StdReflect.setProperty; + ] []; + init_fields builtins (["haxe"],"Resource") [ + "listNames",StdResource.listNames; + "getString",StdResource.getString; + "getBytes",StdResource.getBytes; + ] []; + init_fields builtins (["sys";"net";"_Socket"],"NativeSocket") [ + "select",StdSocket.select; + ] [ + "accept",StdSocket.accept; + "bind",StdSocket.bind; + "close",StdSocket.close; + "connect",StdSocket.connect; + "host",StdSocket.host; + "listen",StdSocket.listen; + "peer",StdSocket.peer; + "receive",StdSocket.receive; + "receiveChar",StdSocket.receiveChar; + "send",StdSocket.send; + "sendChar",StdSocket.sendChar; + "setFastSend",StdSocket.setFastSend; + "setTimeout",StdSocket.setTimeout; + "shutdown",StdSocket.shutdown; + ]; + init_fields builtins ([],"Std") [ + "instance",StdStd.instance; + "int",StdStd.int; + "is",StdStd.is'; + "parseFloat",StdStd.parseFloat; + "parseInt",StdStd.parseInt; + "string",StdStd.string; + "random",StdStd.random; + ] []; + init_fields builtins ([],"String") [ + "fromCharCode",StdString.fromCharCode; + ] [ + "charAt",StdString.charAt; + "charCodeAt",StdString.charCodeAt; + "indexOf",StdString.indexOf; + "lastIndexOf",StdString.lastIndexOf; + "split",StdString.split; + "substr",StdString.substr; + "substring",StdString.substring; + "toLowerCase",StdString.toLowerCase; + "toString",StdString.toString; + "toUpperCase",StdString.toUpperCase; + "cca",StdString.cca; + ]; + init_fields builtins ([],"StringBuf") [] [ + "add",StdStringBuf.add; + "addChar",StdStringBuf.addChar; + "addSub",StdStringBuf.addSub; + "get_length",StdStringBuf.get_length; + "toString",StdStringBuf.toString; + ]; + init_fields builtins ([],"StringTools") [ + "fastCodeAt",StdStringTools.fastCodeAt; + "urlEncode",StdStringTools.urlEncode; + "urlDecode",StdStringTools.urlDecode; + ] []; + init_fields builtins ([],"Sys") [ + "args",StdSys.args; + "_command",StdSys._command; + "cpuTime",StdSys.cpuTime; + "environment",StdSys.environment; + "exit",StdSys.exit; + "getChar",StdSys.getChar; + "getCwd",StdSys.getCwd; + "getEnv",StdSys.getEnv; + "print",StdSys.print; + "println",StdSys.println; + "programPath",StdSys.programPath; + "putEnv",StdSys.putEnv; + "setCwd",StdSys.setCwd; + "setTimeLocale",StdSys.setTimeLocale; + "sleep",StdSys.sleep; + "stderr",StdSys.stderr; + "stdin",StdSys.stdin; + "stdout",StdSys.stdout; + "systemName",StdSys.systemName; + "time",StdSys.time; + ] []; + init_fields builtins ([],"Type") [ + "allEnums",StdType.allEnums; + "createEmptyInstance",StdType.createEmptyInstance; + "createEnum",StdType.createEnum; + "createEnumIndex",StdType.createEnumIndex; + "createInstance",StdType.createInstance; + "enumConstructor",StdType.enumConstructor; + "enumEq",StdType.enumEq; + "enumIndex",StdType.enumIndex; + "enumParameters",StdType.enumParameters; + "getClass",StdType.getClass; + "getClassFields",StdType.getClassFields; + "getClassName",StdType.getClassName; + "getEnum",StdType.getEnum; + "getEnumConstructs",StdType.getEnumConstructs; + "getEnumName",StdType.getEnumName; + "getInstanceFields",StdType.getInstanceFields; + "getSuperClass",StdType.getSuperClass; + "resolveClass",StdType.resolveClass; + "resolveEnum",StdType.resolveEnum; + "typeof",StdType.typeof; + ] []; + init_fields builtins (["haxe";"zip"],"Uncompress") [ + "run",StdUncompress.run; + ] [ + "close",StdUncompress.close; + "execute",StdUncompress.execute; + "setFlushMode",StdUncompress.setFlushMode; + ]; + init_fields builtins (["haxe"],"Utf8") [ + "charCodeAt",StdUtf8.charCodeAt; + "compare",StdUtf8.compare; + "decode",StdUtf8.decode; + "encode",StdUtf8.encode; + "iter",StdUtf8.iter; + "length",StdUtf8.length; + "sub",StdUtf8.sub; + "validate",StdUtf8.validate; + ] [ + "addChar",StdUtf8.addChar; + "toString",StdUtf8.toString; + ] \ No newline at end of file diff --git a/src/macro/eval/evalValue.ml b/src/macro/eval/evalValue.ml new file mode 100644 index 00000000000..f522ddd0556 --- /dev/null +++ b/src/macro/eval/evalValue.ml @@ -0,0 +1,201 @@ +(* + The Haxe Compiler + Copyright (C) 2005-2017 Haxe Foundation + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +open Globals +open EvalHash + +type cmp = + | CEq + | CSup + | CInf + | CUndef + +type vstring = Rope.t * string Lazy.t + +module StringHashtbl = Hashtbl.Make(struct + type t = vstring + let equal (r1,s1) (r2,s2) = r1 == r2 || Lazy.force s1 = Lazy.force s2 + let hash (_,s) = Hashtbl.hash (Lazy.force s) +end) + +module IntHashtbl = Hashtbl.Make(struct type t = int let equal = (=) let hash = Hashtbl.hash end) + +type vregex = { + r : Pcre.regexp; + r_global : bool; + mutable r_string : string; + mutable r_groups : Pcre.substrings array; +} + +type vzlib = { + z : Extc.zstream; + mutable z_flush : Extc.zflush; +} + +type vprototype_kind = + | PClass of int list + | PEnum of string list + | PInstance + | PObject + +type value = + | VNull + | VTrue + | VFalse + | VInt32 of int32 + | VFloat of float + | VEnumValue of venum_value + | VObject of vobject + | VInstance of vinstance + | VString of vstring + | VArray of varray + | VVector of vvector + | VPrototype of vprototype + | VFunction of vfunc * bool + | VFieldClosure of value * vfunc + +and vfunc = + | Fun0 of (unit -> value) + | Fun1 of (value -> value) + | Fun2 of (value -> value -> value) + | Fun3 of (value -> value -> value -> value) + | Fun4 of (value -> value -> value -> value -> value) + | Fun5 of (value -> value -> value -> value -> value -> value) + | FunN of (value list -> value) + +and vobject = { + (* The fields of the object known when it is created. *) + ofields : value array; + (* The prototype of the object. *) + oproto : vprototype; + (* Extra fields that were added after the object was created. *) + mutable oextra : value IntMap.t; + (* Map of fields (in ofields) that were deleted via Reflect.deleteField *) + mutable oremoved : bool IntMap.t; +} + +and vprototype = { + (* The path of the prototype. Using rev_hash_s on this gives the original dot path. *) + ppath : int; + (* The fields of the prototype itself (static fields). *) + pfields : value array; + (* Map from hashed name to field offset (in pfields). *) + pnames : int IntMap.t; + (* The fields of instances of this prototype (non-static fields). *) + pinstance_fields : value array; + (* Map from hashed name to field offset (in pinstance_fields). *) + pinstance_names : int IntMap.t; + (* + The parent prototype in case of inheritance. Static inheritance is reflected here + as well because that information is requires for Type.getSuperClass. + *) + pparent : vprototype option; + (* The [vprototype_kind]. *) + pkind : vprototype_kind; + (* The value of this prototype, i.e. VPrototype self. *) + mutable pvalue : value; +} + +and vinstance_kind = + | IBytes of bytes + | IRegex of vregex + | IDate of float + | IStringMap of value StringHashtbl.t + | IIntMap of value IntHashtbl.t + | IObjectMap of (value,value) Hashtbl.t + | IOutput of Buffer.t (* BytesBuffer *) + | IBuffer of Rope.Buffer.t (* StringBuf *) + | IPos of pos + | IUtf8 of UTF8.Buf.buf + | IProcess of Process.process + | IInChannel of in_channel * bool ref (* FileInput *) + | IOutChannel of out_channel (* FileOutput *) + | ISocket of Unix.file_descr + | IThread of Thread.t + | IZip of vzlib (* Compress/Uncompress *) + | ITypeDecl of Type.module_type + | ILazyType of ((unit -> Type.t) ref) * (unit -> value) + | IRef of Obj.t + | INormal + +and vinstance = { + (* The fields of this instance. *) + ifields : value array; + (* + The prototype of this instance. Field offsets for ifields can be found using + iproto.pinstance_names. + *) + iproto : vprototype; + (* The [vinstance_kind]. *) + ikind : vinstance_kind; +} + +and varray = { + mutable avalues : value array; + mutable alength : int +} + +and vvector = value array + +and venum_value = { + eindex : int; + eargs : value array; + epath : int; + enpos : pos option; +} + +module ValueHashtbl = Hashtbl.Make(struct + type t = value + + let equal a b = match a,b with + | VObject o1,VObject o2 -> o1 == o2 + | VInstance vi1,VInstance vi2 -> vi1 == vi2 + | VPrototype p1,VPrototype p2 -> p1 == p2 + | VFunction(f1,_),VFunction(f2,_) -> f1 == f2 + | VFieldClosure(v1,f1),VFieldClosure(v2,f2) -> v1 == v2 && f1 == f2 + | _ -> false + + let hash = Hashtbl.hash +end) + +let vnull = VNull +let vtrue = VTrue +let vfalse = VFalse +let vbool b = if b then VTrue else VFalse +let vprototype proto = VPrototype proto +let vinstance i = VInstance i +let vfunction f = VFunction(f,false) +let vstatic_function f = VFunction(f,true) +let vfield_closure v f = VFieldClosure(v,f) +let vobject o = VObject o +let vint i = VInt32 (Int32.of_int i) +let vint32 i = VInt32 i +let vfloat f = VFloat f +let venum_value e = VEnumValue e + +let s_expr_pretty e = (Type.s_expr_pretty false "" false (Type.s_type (Type.print_context())) e) + +let num_args = function + | Fun0 _ -> 0 + | Fun1 _ -> 1 + | Fun2 _ -> 2 + | Fun3 _ -> 3 + | Fun4 _ -> 4 + | Fun5 _ -> 5 + | FunN _ -> -1 \ No newline at end of file diff --git a/src/macro/macroApi.ml b/src/macro/macroApi.ml index 36f0ab189a6..c955e24d19c 100644 --- a/src/macro/macroApi.ml +++ b/src/macro/macroApi.ml @@ -48,6 +48,10 @@ type 'value compiler_api = { cast_or_unify : Type.t -> texpr -> Globals.pos -> Type.texpr; add_global_metadata : string -> string -> (bool * bool * bool) -> unit; add_module_check_policy : string list -> int list -> bool -> int -> unit; + decode_expr : 'value -> Ast.expr; + encode_expr : Ast.expr -> 'value; + encode_ctype : Ast.type_hint -> 'value; + decode_type : 'value -> t; } diff --git a/src/macro/macroContext.ml b/src/macro/macroContext.ml index 27bdb3621c9..c8ad7dc2932 100644 --- a/src/macro/macroContext.ml +++ b/src/macro/macroContext.ml @@ -25,7 +25,15 @@ open Typecore open Error open Globals -module InterpImpl = Interp (* Hlmacro *) +module Eval = struct + include EvalEncode + include EvalDecode + include EvalValue + include EvalContext + include EvalMain +end + +module InterpImpl = Eval (* Hlmacro *) module Interp = struct module BuiltApi = MacroApi.MacroApiImpl(InterpImpl) @@ -357,6 +365,10 @@ let make_macro_api ctx p = MacroApi.on_reuse = (fun f -> macro_interp_on_reuse := f :: !macro_interp_on_reuse ); + MacroApi.decode_expr = Interp.decode_expr; + MacroApi.encode_expr = Interp.encode_expr; + MacroApi.encode_ctype = Interp.encode_ctype; + MacroApi.decode_type = Interp.decode_type; } let rec init_macro_interp ctx mctx mint = @@ -681,7 +693,7 @@ let type_macro ctx mode cpath f (el:Ast.expr list) p = else try let ct = Interp.decode_ctype v in Typeload.load_complex_type ctx false p ct; - with MacroApi.Invalid_expr -> + with MacroApi.Invalid_expr | EvalContext.RunTimeException _ -> Interp.decode_type v in ctx.ret <- t; @@ -758,8 +770,8 @@ let interpret ctx = let mctx = Interp.create ctx.com (make_macro_api ctx null_pos) false in Interp.add_types mctx ctx.com.types (fun t -> ()); match ctx.com.main with - | None -> () - | Some e -> ignore(Interp.eval_expr mctx e) + | None -> () + | Some e -> ignore(Interp.eval_expr mctx e) let setup() = Interp.setup Interp.macro_api diff --git a/std/eval/Vector.hx b/std/eval/Vector.hx new file mode 100644 index 00000000000..a1d9919c1f9 --- /dev/null +++ b/std/eval/Vector.hx @@ -0,0 +1,33 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package eval; + +extern class Vector implements ArrayAccess { + public function new(size:Int) : Void; + public var length(default, null):Int; + public function blit(srcPos:Int, dest:Vector, destPos:Int, len:Int):Void; + public function toArray():Array; + static public function fromArrayCopy(array:Array):Vector; + public function copy():Vector; + public function join(sep:String):String; + public function map(f:T->S):Vector; +} \ No newline at end of file diff --git a/std/eval/_std/EReg.hx b/std/eval/_std/EReg.hx new file mode 100644 index 00000000000..9673f9b0475 --- /dev/null +++ b/std/eval/_std/EReg.hx @@ -0,0 +1,39 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ + +// We need this class so that calls to the empty standard implementations +// don't get optimized away. + +@:coreApi +extern class EReg { + public function new( r : String, opt : String ):Void; + public function match( s : String ) : Bool; + public function matched( n : Int ) : String; + public function matchedLeft() : String; + public function matchedRight() : String; + public function matchedPos() : { pos : Int, len : Int }; + public function matchSub( s : String, pos : Int, len : Int = -1):Bool; + public function split( s : String ) : Array; + public function replace( s : String, by : String ) : String; + public function map( s : String, f : EReg -> String ) : String; + public static function escape( s : String ) : String; +} \ No newline at end of file diff --git a/std/eval/_std/StringBuf.hx b/std/eval/_std/StringBuf.hx new file mode 100644 index 00000000000..3ab072a11e2 --- /dev/null +++ b/std/eval/_std/StringBuf.hx @@ -0,0 +1,32 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ + +@:coreApi +extern class StringBuf { + public var length(get,never) : Int; + public function new():Void; + function get_length() : Int; + public function add( x : T ) : Void; + public function addChar( c : Int ) : Void; + public function addSub( s : String, pos : Int, ?len : Int) : Void; + public function toString() : String; +} \ No newline at end of file diff --git a/std/eval/_std/Sys.hx b/std/eval/_std/Sys.hx new file mode 100644 index 00000000000..99f4a607795 --- /dev/null +++ b/std/eval/_std/Sys.hx @@ -0,0 +1,68 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ + +@:require(sys) +@:coreApi +class Sys { + @:extern static public function print(v:Dynamic):Void { } + @:extern static public function println(v:Dynamic):Void { } + @:extern static public function args():Array { return []; } + @:extern static public function getEnv(s:String):String { return ""; } + @:extern static public function putEnv(s:String, v:String):Void { } + @:extern static public function environment():Map { return null; } + @:extern static public function sleep(seconds:Float):Void { } + @:extern static public function setTimeLocale(loc:String):Bool { return false; } + @:extern static public function getCwd():String { return ""; } + @:extern static public function setCwd(s:String):Void { } + @:extern static public function systemName():String { return ""; } + + @:extern static function _command(cmd:String):Int { return 0; } + + static public function command(cmd:String, ?args:Array):Int { + if (args == null) { + return _command(cmd); + } else { + switch (systemName()) { + case "Windows": + cmd = [ + for (a in [StringTools.replace(cmd, "/", "\\")].concat(args)) + StringTools.quoteWinArg(a, true) + ].join(" "); + return _command(cmd); + case _: + cmd = [cmd].concat(args).map(StringTools.quoteUnixArg).join(" "); + return _command(cmd); + } + } + } + + static public function executablePath():String { return programPath(); } + + @:extern static public function exit(code:Int):Void { } + @:extern static public function time():Float { return 0.; } + @:extern static public function cpuTime():Float { return 0.; } + @:extern static public function programPath():String { return ""; } + @:extern static public function getChar(echo:Bool):Int { return 0; } + @:extern static public function stdin():haxe.io.Input { return (null : sys.io.FileInput); } + @:extern static public function stdout():haxe.io.Output { return (null : sys.io.FileOutput); } + @:extern static public function stderr():haxe.io.Output { return (null : sys.io.FileOutput); } +} \ No newline at end of file diff --git a/std/eval/_std/haxe/Resource.hx b/std/eval/_std/haxe/Resource.hx new file mode 100644 index 00000000000..3ab2977c0d0 --- /dev/null +++ b/std/eval/_std/haxe/Resource.hx @@ -0,0 +1,29 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package haxe; + +@:coreApi +extern class Resource { + public static function listNames() : Array; + public static function getString( name : String ) : String; + public static function getBytes( name : String ) : haxe.io.Bytes; +} diff --git a/std/eval/_std/haxe/Utf8.hx b/std/eval/_std/haxe/Utf8.hx new file mode 100644 index 00000000000..d24904ae2c8 --- /dev/null +++ b/std/eval/_std/haxe/Utf8.hx @@ -0,0 +1,37 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package haxe; + +@:coreApi +extern class Utf8 { + public function new( ?size : Int ):Void; + public function addChar( c : Int ) : Void; + public function toString() : String; + public static function iter( s : String, chars : Int -> Void ):Void; + public static function encode( s : String ) : String; + public static function decode( s : String ) : String; + public static function charCodeAt( s : String, index : Int ) : Int; + public static function validate( s : String ) : Bool; + public static function length( s : String ) : Int; + public static function compare( a : String, b : String ) : Int; + public static function sub( s : String, pos : Int, len : Int ) : String; +} \ No newline at end of file diff --git a/std/eval/_std/haxe/io/Bytes.hx b/std/eval/_std/haxe/io/Bytes.hx new file mode 100644 index 00000000000..b59424a8515 --- /dev/null +++ b/std/eval/_std/haxe/io/Bytes.hx @@ -0,0 +1,54 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package haxe.io; + +extern class Bytes { + public var length(default,null):Int; + public function get( pos : Int ) : Int; + public function set( pos : Int, v : Int ) : Void; + public function blit( pos : Int, src : Bytes, srcpos : Int, len : Int ) : Void; + public function fill( pos : Int, len : Int, value : Int ):Void; + public function sub( pos : Int, len : Int ) : Bytes; + public function compare( other : Bytes ) : Int; + public function getDouble( pos : Int ) : Float; + public function getFloat( pos : Int ) : Float; + public function setDouble( pos : Int, v : Float ) : Void; + public function setFloat( pos : Int, v : Float ) : Void; + public function getUInt16( pos : Int ) : Int; + public function setUInt16( pos : Int, v : Int ) : Void; + public function getInt32( pos : Int ) : Int; + public function getInt64( pos : Int ) : haxe.Int64; + public function setInt32( pos : Int, v : Int ) : Void; + public function setInt64( pos : Int, v : haxe.Int64 ) : Void; + public function getString( pos : Int, len : Int ) : String; + public function toString() : String; + public function toHex() : String; + public function getData() : BytesData; + public static function alloc( length : Int ) : Bytes; + @:pure + public static function ofString( s : String ) : Bytes; + public static function ofData( b : BytesData ) : Bytes; + public static function fastGet( b : BytesData, pos : Int ) : Int; + static function __init__():Void { + haxe.io.Error; + } +} diff --git a/std/eval/_std/haxe/io/BytesBuffer.hx b/std/eval/_std/haxe/io/BytesBuffer.hx new file mode 100644 index 00000000000..313da9f81f3 --- /dev/null +++ b/std/eval/_std/haxe/io/BytesBuffer.hx @@ -0,0 +1,38 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package haxe.io; + +@:coreApi +extern class BytesBuffer { + public var length(get, never):Int; + public function new():Void; + function get_length():Int; + public function addByte(byte:Int):Void; + public function add(src:Bytes):Void; + public function addString(v:String):Void; + public function addInt32(v:Int):Void; + public function addInt64(v:haxe.Int64):Void; + public function addFloat(v:Float):Void; + public function addDouble(v:Float):Void; + public function addBytes(src:Bytes, pos:Int, len:Int):Void; + public function getBytes():Bytes; +} diff --git a/std/eval/_std/haxe/io/BytesData.hx b/std/eval/_std/haxe/io/BytesData.hx new file mode 100644 index 00000000000..7d01ba96098 --- /dev/null +++ b/std/eval/_std/haxe/io/BytesData.hx @@ -0,0 +1,30 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package haxe.io; + +@:forward +private abstract BytesDataAbstract(Bytes) from Bytes to Bytes { + @:arrayAccess public inline function get(i:Int) return this.get(i); + @:arrayAccess public inline function set(i:Int, v:Dynamic) this.set(i, v); +} + +typedef BytesData = BytesDataAbstract; \ No newline at end of file diff --git a/std/eval/_std/haxe/zip/Compress.hx b/std/eval/_std/haxe/zip/Compress.hx new file mode 100644 index 00000000000..72977216a47 --- /dev/null +++ b/std/eval/_std/haxe/zip/Compress.hx @@ -0,0 +1,30 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package haxe.zip; + +extern class Compress { + public function new(level:Int):Void; + public function execute(src:haxe.io.Bytes, srcPos:Int, dst:haxe.io.Bytes, dstPos:Int):{ done:Bool, read:Int, wriet:Int }; + public function setFlushMode(f:FlushMode):Void; + public function close():Void; + public static function run(s:haxe.io.Bytes, level:Int):haxe.io.Bytes; +} \ No newline at end of file diff --git a/std/eval/_std/haxe/zip/Uncompress.hx b/std/eval/_std/haxe/zip/Uncompress.hx new file mode 100644 index 00000000000..73fdada4943 --- /dev/null +++ b/std/eval/_std/haxe/zip/Uncompress.hx @@ -0,0 +1,30 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package haxe.zip; + +extern class Uncompress { + public function new(?windowBits:Int):Void; + public function execute(src:haxe.io.Bytes, srcPos:Int, dst:haxe.io.Bytes, dstPos:Int):{ done:Bool, read:Int, write:Int }; + public function setFlushMode(f:FlushMode):Void; + public function close():Void; + public static function run(src:haxe.io.Bytes, ?bufsize:Int):haxe.io.Bytes; +} diff --git a/std/eval/_std/sys/FileSystem.hx b/std/eval/_std/sys/FileSystem.hx new file mode 100644 index 00000000000..6139a6b71c2 --- /dev/null +++ b/std/eval/_std/sys/FileSystem.hx @@ -0,0 +1,39 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package sys; + +// This class is here so it re-shadows other FileSystem classes in macros, +// e.g. from hxnodejs. + +@:coreApi +extern class FileSystem { + static function exists(path:String):Bool; + static function rename(path:String, newPath:String):Void; + static function stat(path:String):FileStat; + static function fullPath(relPath:String):String; + static function absolutePath(relPath:String):String; + static function isDirectory(path:String):Bool; + static function createDirectory(path:String):Void; + static function deleteFile(path:String):Void; + static function deleteDirectory(path:String):Void; + static function readDirectory(path:String):Array; +} diff --git a/std/eval/_std/sys/io/File.hx b/std/eval/_std/sys/io/File.hx new file mode 100644 index 00000000000..c85826ee6f1 --- /dev/null +++ b/std/eval/_std/sys/io/File.hx @@ -0,0 +1,41 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package sys.io; + +@:coreApi +class File { + @:extern static public function getContent(path:String):String { return ""; } + @:extern static public function saveContent(path:String, content:String):Void { } + @:extern static public function getBytes(path:String):haxe.io.Bytes { return haxe.io.Bytes.alloc(0); } + @:extern static public function saveBytes(path:String, bytes:haxe.io.Bytes):Void { } + @:extern static public function read(path:String, binary:Bool = true):FileInput { return null; } + @:extern static public function write(path:String, binary:Bool = true):FileOutput { return null; } + @:extern static public function append(path:String, binary:Bool = true):FileOutput { return null; } + + static public function copy(srcPath:String, dstPath:String):Void { + var s = read(srcPath, true); + var d = write(dstPath, true); + d.writeInput(s); + s.close(); + d.close(); + } +} diff --git a/std/eval/_std/sys/io/FileInput.hx b/std/eval/_std/sys/io/FileInput.hx new file mode 100644 index 00000000000..f98ae199565 --- /dev/null +++ b/std/eval/_std/sys/io/FileInput.hx @@ -0,0 +1,34 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package sys.io; + +// This class is not extern because externs overriding non-externs messes with DCE + +@:coreApi +class FileInput extends haxe.io.Input { + @:extern public override function close():Void { } + @:extern public function eof():Bool { return false; } + @:extern public function seek(p:Int, pos:FileSeek):Void { } + @:extern public function tell():Int { return 0; } + @:extern public override function readByte():Int { return 0; } + @:extern public override function readBytes(bytes:haxe.io.Bytes, pos:Int, len:Int):Int { return 0; } +} diff --git a/std/eval/_std/sys/io/FileOutput.hx b/std/eval/_std/sys/io/FileOutput.hx new file mode 100644 index 00000000000..64bb0606f61 --- /dev/null +++ b/std/eval/_std/sys/io/FileOutput.hx @@ -0,0 +1,34 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package sys.io; + +// This class is not extern because externs overriding non-externs messes with DCE + +@:coreApi +class FileOutput extends haxe.io.Output { + @:extern public override function close():Void { } + @:extern public override function flush():Void { } + @:extern public function seek(p:Int, pos:FileSeek):Void { } + @:extern public function tell():Int { return 0; } + @:extern public override function writeByte(c:Int):Void { } + @:extern public override function writeBytes(bytes:haxe.io.Bytes, pos:Int, len:Int):Int { return 0; } +} diff --git a/std/eval/_std/sys/io/Process.hx b/std/eval/_std/sys/io/Process.hx new file mode 100644 index 00000000000..f0ad764b774 --- /dev/null +++ b/std/eval/_std/sys/io/Process.hx @@ -0,0 +1,131 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package sys.io; + +private extern class NativeProcess { + function new (cmd:String, ?args:Array):Void; + + function close():Void; + function exitCode():Int; + function getPid():Int; + function kill():Void; + + function readStderr(bytes:haxe.io.Bytes, pos:Int, len:Int):Int; + function readStdout(bytes:haxe.io.Bytes, pos:Int, len:Int):Int; + + function closeStdin():Void; + function writeStdin(bytes:haxe.io.Bytes, pos:Int, len:Int):Int; +} + +private class Stdin extends haxe.io.Output { + var proc:NativeProcess; + var buf:haxe.io.Bytes; + + public function new(proc:NativeProcess) { + this.proc = proc; + buf = haxe.io.Bytes.alloc(1); + } + + public override function close() { + super.close(); + proc.closeStdin(); + } + + public override function writeByte(c:Int) { + buf.set(0,c); + writeBytes(buf,0,1); + } + + public override function writeBytes(buf:haxe.io.Bytes, pos:Int, len:Int) { + try { + return proc.writeStdin(buf, pos, len); + } catch( e:Dynamic ) { + throw new haxe.io.Eof(); + } + } +} + +private class Stdout extends haxe.io.Input { + var proc:NativeProcess; + var out:Bool; + var buf:haxe.io.Bytes; + + public function new(proc:NativeProcess, out:Bool) { + this.proc = proc; + this.out = out; + buf = haxe.io.Bytes.alloc(1); + } + + public override function readByte() { + if(readBytes(buf,0,1) == 0) + throw haxe.io.Error.Blocked; + return buf.get(0); + } + + public override function readBytes(bytes:haxe.io.Bytes, pos:Int, len:Int):Int { + try { + if (out) { + return proc.readStdout(bytes, pos, len); + } else { + return proc.readStderr(bytes, pos, len); + } + } catch( e:Dynamic ) { + throw new haxe.io.Eof(); + } + } +} + +@:coreApi +class Process { + public var stdout(default, null):haxe.io.Input; + public var stderr(default, null):haxe.io.Input; + public var stdin(default, null):haxe.io.Output; + + var proc:NativeProcess; + + public function new(cmd:String, ?args:Array, ?detached:Bool):Void { + if (detached) { + throw "Detached process is not supported on this platform"; + } + proc = new NativeProcess(cmd, args); + stdout = new Stdout(proc, true); + stderr = new Stdout(proc, false); + stdin = new Stdin(proc); + } + + public inline function getPid():Int { + return proc.getPid(); + } + + public function exitCode(block:Bool = true):Null { + if( block == false ) throw "Non blocking exitCode() not supported on this platform"; + return proc.exitCode(); + } + + public inline function close():Void { + proc.close(); + } + + public inline function kill():Void { + proc.kill(); + } +} \ No newline at end of file diff --git a/std/eval/_std/sys/net/Host.hx b/std/eval/_std/sys/net/Host.hx new file mode 100644 index 00000000000..b7452210d60 --- /dev/null +++ b/std/eval/_std/sys/net/Host.hx @@ -0,0 +1,49 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package sys.net; + +class Host { + public var host(default,null):String; + public var ip(default,null):Int; + + public function new(name:String) { + host = name; + init(resolve(name)); + } + + public function toString() { + return hostToString(ip); + } + + public function reverse() { + return hostReverse(ip); + } + + function init(ip:Int) { + this.ip = ip; + } + + @:extern static public function localhost() { return ""; } + @:extern static function hostReverse(ip:Int) { return ""; } + @:extern static function hostToString(ip:Int) { return ""; } + @:extern static function resolve(name:String) { return 0; } +} \ No newline at end of file diff --git a/std/eval/_std/sys/net/Socket.hx b/std/eval/_std/sys/net/Socket.hx new file mode 100644 index 00000000000..29b0261aacd --- /dev/null +++ b/std/eval/_std/sys/net/Socket.hx @@ -0,0 +1,208 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package sys.net; + +import haxe.io.Error; + +extern private class NativeSocket { + function new():Void; + function accept():NativeSocket; + function bind(host:Int, port:Int):Void; + function close():Void; + function connect(host:Int, port:Int):Void; + function host():{ip:Int, port:Int}; + function listen(connections:Int):Void; + function peer():{ip:Int, port:Int}; + function receive(buf:haxe.io.Bytes, pos:Int, len:Int):Int; + function receiveChar():Int; + function send(buf:haxe.io.Bytes, pos:Int, len:Int):Int; + function sendChar(char:Int):Void; + function setFastSend(b:Bool):Void; + function setTimeout(timeout:Float):Void; + function shutdown(read:Bool, write:Bool):Void; + + public static function select(read:Array, write:Array, others:Array, ?timeout:Float):{ read: Array,write: Array,others: Array }; +} + +private class SocketOutput extends haxe.io.Output { + var socket:NativeSocket; + + public function new(socket:NativeSocket) { + this.socket = socket; + } + + public override function writeByte(c:Int) { + try { + socket.sendChar(c); + } catch( e : Dynamic ) { + if( e == "Blocking" ) + throw Blocked; + else if ( e == "EOF" ) + throw new haxe.io.Eof(); + else + throw Custom(e); + } + } + + public override function writeBytes(buf:haxe.io.Bytes, pos:Int, len:Int) { + return try { + socket.send(buf, pos, len); + } catch( e : Dynamic ) { + if( e == "Blocking" ) + throw Blocked; + else + throw Custom(e); + } + } + + public override function close() { + super.close(); + socket.close(); + } +} + +private class SocketInput extends haxe.io.Input { + var socket:NativeSocket; + + public function new(socket:NativeSocket) { + this.socket = socket; + } + + public override function readByte() { + return try { + socket.receiveChar(); + } catch( e : Dynamic ) { + if( e == "Blocking" ) + throw Blocked; + else + throw new haxe.io.Eof(); + } + } + + public override function readBytes(buf:haxe.io.Bytes, pos:Int, len:Int) { + var r; + try { + r = socket.receive(buf, pos, len); + } catch( e : Dynamic ) { + if( e == "Blocking" ) + throw Blocked; + else + throw Custom(e); + } + if( r == 0 ) + throw new haxe.io.Eof(); + return r; + } + + public override function close() { + super.close(); + socket.close(); + } +} + +@:coreApi +class Socket { + public var input(default,null):haxe.io.Input; + public var output(default,null):haxe.io.Output; + public var custom:Dynamic; + + @:ifFeature("sys.net.Socket.select") var socket:NativeSocket; + + public function new() { + init(new NativeSocket()); + } + + private function init(socket:NativeSocket):Void { + this.socket = socket; + input = new SocketInput(socket); + output = new SocketOutput(socket); + } + + public function close():Void { + socket.close(); + } + + public function read():String { + return input.readAll().toString(); + } + + public function write(content:String):Void { + output.writeString(content); + } + + public function connect(host:Host, port:Int):Void { + socket.connect(host.ip, port); + } + + public function listen(connections:Int):Void { + socket.listen(connections); + } + + public function shutdown(read:Bool, write:Bool):Void { + socket.shutdown(read, write); + } + + public function bind(host:Host, port:Int):Void { + socket.bind(host.ip, port); + } + + public function accept():Socket { + var nativeSocket = socket.accept(); + var socket:Socket = Type.createEmptyInstance(Socket); + socket.init(nativeSocket); + return socket; + } + + @:access(sys.net.Host.init) + public function peer():{host:Host, port:Int} { + var info = socket.peer(); + var host:Host = Type.createEmptyInstance(Host); + host.init(info.ip); + return { host: host, port: info.port }; + } + + @:access(sys.net.Host.init) + public function host():{host:Host, port:Int} { + var info = socket.host(); + var host:Host = Type.createEmptyInstance(Host); + host.init(info.ip); + return { host: host, port: info.port }; + } + + public function setTimeout(timeout:Float):Void { + socket.setTimeout(timeout); + } + + public function waitForRead():Void { + select([this], null, null, -1); + } + + public function setBlocking(b:Bool):Void { } // TODO: Don't know how to implement this... + + public function setFastSend(b:Bool):Void { + socket.setFastSend(b); + } + + public static function select(read:Array, write:Array, others:Array, ?timeout:Float):{ read: Array,write: Array,others: Array } { + return NativeSocket.select(read, write, others, timeout); + } +} diff --git a/std/eval/vm/Context.hx b/std/eval/vm/Context.hx new file mode 100644 index 00000000000..53ac32cdd56 --- /dev/null +++ b/std/eval/vm/Context.hx @@ -0,0 +1,61 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package eval.vm; + +extern class Context { + static function addBreakpoint(file:String, line:Int):Void; + static function breakHere():Void; + static function callMacroApi(s:String):Dynamic; + + /** + Loads and returns a plugin from file `filePath`. + + If Haxe is built natively, the extension automatically defaults to `.cmxs`, + even if a different extension is provided in `filePath`. In bytecode mode, + the default extension is `.cmo`. + + Sample plugin: + + ```open EvalValue +open EvalContext +open EvalEncode + +let add_int = vfun2 (fun v1 v2 -> match v1,v2 with + | VInt32 i1,VInt32 i2 -> vint32 (Int32.add i1 i2) + | _ -> exc_string "Expected int + int" +) +;; +EvalStdLib.StdContext.register ["add_int",add_int] +``` + + Usage from Haxe: + + ```var module:TestPlugin = eval.vm.Context.loadPlugin("testPlugin.cmo"); +trace(module.add_int(4, 3)); +``` + + Plugins have to be compiled with the same OCaml version as the Haxe compiler + and using the same Haxe version. If a plugin cannot be loaded, an exception + of type `String` is thrown. + **/ + static function loadPlugin(filePath:String):T; +} \ No newline at end of file diff --git a/std/eval/vm/Gc.hx b/std/eval/vm/Gc.hx new file mode 100644 index 00000000000..52f79d13b0b --- /dev/null +++ b/std/eval/vm/Gc.hx @@ -0,0 +1,232 @@ +/* + * Copyright (C)2005-2017 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ +package eval.vm; + +/** +The memory management counters are returned in a stat record. +The total amount of memory allocated by the program since it was started is (in words) minor_words + major_words - promoted_words. Multiply by the word size (4 on a 32-bit machine, 8 on a 64-bit machine) to get the number of bytes. +**/ +typedef Stat = { + /** + Number of words allocated in the minor heap since the program was started. This number is accurate in byte-code programs, but only an approximation in programs compiled to native code. + **/ + var minor_words:Float; + + /** + Number of words allocated in the minor heap that survived a minor collection and were moved to the major heap since the program was started. + **/ + var promoted_words:Float; + + /** + Number of words allocated in the major heap, including the promoted words, since the program was started. + **/ + var major_words:Float; + + /** + Number of minor collections since the program was started. + **/ + var minor_collections:Float; + + /** + Number of major collection cycles completed since the program was started. + **/ + var major_collections:Float; + + /** + Total size of the major heap, in words. + **/ + var heap_words:Int; + + /** + Number of contiguous pieces of memory that make up the major heap. + **/ + var heap_chunks:Int; + + /** + Number of words of live data in the major heap, including the header words. + **/ + var live_words:Int; + + /** + Number of live blocks in the major heap. + **/ + var live_blocks:Int; + + /** + Number of words in the free list. + **/ + var free_words:Int; + + /** + Number of blocks in the free list. + **/ + var free_blocks:Int; + + /** + Size (in words) of the largest block in the free list. + **/ + var largest_free:Int; + + /** + Number of wasted words due to fragmentation. These are 1-words free blocks placed between two live blocks. They are not available for allocation. + **/ + var fragments:Int; + + /** + Number of heap compactions since the program was started. + **/ + var compactions:Int; + + /** + Maximum size reached by the major heap, in words. + **/ + var top_heap_words:Int; + + /** + Current size of the stack, in words. + **/ + var stack_size:Int; +} + +/** +The GC parameters are given as a control record. Note that these parameters can also be initialised by setting the OCAMLRUNPARAM environment variable. See the documentation of ocamlrun. +**/ +typedef Control = { + /** + The size (in words) of the minor heap. Changing this parameter will trigger a minor collection. Default: 256k. + **/ + var minor_heap_size:Int; + + /** + How much to add to the major heap when increasing it. If this number is less than or equal to 1000, it is a percentage of the current heap size (i.e. setting it to 100 will double the heap size at each increase). If it is more than 1000, it is a fixed number of words that will be added to the heap. Default: 15. + **/ + var major_heap_increment:Int; + + /** + The major GC speed is computed from this parameter. This is the memory that will be "wasted" because the GC does not immediatly collect unreachable blocks. It is expressed as a percentage of the memory used for live data. The GC will work more (use more CPU time and collect blocks more eagerly) if space_overhead is smaller. Default: 80. + **/ + var space_overhead:Int; + + /** + This value controls the GC messages on standard error output. It is a sum of some of the following flags, to print messages on the corresponding events: + * 0x001 Start of major GC cycle. + * 0x002 Minor collection and major GC slice. + * 0x004 Growing and shrinking of the heap. + * 0x008 Resizing of stacks and memory manager tables. + * 0x010 Heap compaction. + * 0x020 Change of GC parameters. + * 0x040 Computation of major GC slice size. + * 0x080 Calling of finalisation functions. + * 0x100 Bytecode executable and shared library search at start-up. + * 0x200 Computation of compaction-triggering condition. + * 0x400 Output GC statistics at program exit. Default: 0. + **/ + var verbose:Int; + + /** + Heap compaction is triggered when the estimated amount of "wasted" memory is more than max_overhead percent of the amount of live data. If max_overhead is set to 0, heap compaction is triggered at the end of each major GC cycle (this setting is intended for testing purposes only). If max_overhead >= 1000000, compaction is never triggered. If compaction is permanently disabled, it is strongly suggested to set allocation_policy to 1. Default: 500. + **/ + var max_overhead:Int; + + /** + The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime uses the operating system's stack. Default: 1024k. + **/ + var stack_limit:Int; + + /** + The policy used for allocating in the heap. Possible values are 0 and 1. 0 is the next-fit policy, which is quite fast but can result in fragmentation. 1 is the first-fit policy, which can be slower in some cases but can be better for programs with fragmentation problems. Default: 0. + **/ + var allocation_policy:Int; +} + +/** +Memory management control and statistics; finalised values. +**/ +extern class Gc { + /** + Return the total number of bytes allocated since the program was started. It is returned as a float to avoid overflow problems with int on 32-bit machines. + **/ + static function allocated_bytes():Float; + + /** + Perform a full major collection and compact the heap. Note that heap compaction is a lengthy operation. + **/ + static function compact():Void; + + /** + Return (minor_words, promoted_words, major_words). This function is as fast as quick_stat. + **/ + static function counters():{minor_words:Float, promoted_words:Float, major_words:Float}; + + /** + Registers f as a finalisation function for v. v must be heap-allocated. f will be called with v as argument at some point between the first time v becomes unreachable (including through weak pointers) and the time v is collected by the GC. Several functions can be registered for the same value, or even several instances of the same function. Each instance will be called once (or never, if the program terminates before v becomes unreachable). + The GC will call the finalisation functions in the order of deallocation. When several values become unreachable at the same time (i.e. during the same GC cycle), the finalisation functions will be called in the reverse order of the corresponding calls to finalise. If finalise is called in the same order as the values are allocated, that means each value is finalised before the values it depends upon. Of course, this becomes false if additional dependencies are introduced by assignments. + + In the presence of multiple OCaml threads it should be assumed that any particular finaliser may be executed in any of the threads. + **/ + static function finalise(f:T -> Void, v:T):Void; + + /** + Do a minor collection, finish the current major collection cycle, and perform a complete new cycle. This will collect all currently unreachable blocks. + **/ + static function full_major():Void; + + /** + Return the current values of the GC parameters in a control record. + **/ + static function get():Control; + + /** + Do a minor collection and finish the current major collection cycle. + **/ + static function major():Void; + + /** + Do a minor collection and a slice of major collection. n is the size of the slice: the GC will do enough work to free (on average) n words of memory. If n = 0, the GC will try to do enough work to ensure that the next automatic slice has no work to do. This function returns an unspecified integer (currently: 0). + **/ + static function major_slice():Void; + + /** + Trigger a minor collection. + **/ + static function minor():Void; + + /** + Print the current values of the memory management counters (in human-readable form) into the channel argument. + **/ + static function print_stat(out_channel:haxe.io.Output):Void; + + /** + Same as stat except that live_words, live_blocks, free_words, free_blocks, largest_free, and fragments are set to 0. This function is much faster than stat because it does not need to go through the heap. + **/ + static function quick_stat():Stat; + + /** + Changes the GC parameters according to the control record r. + **/ + static function set(r:Control):Void; + + /** + Return the current values of the memory management counters in a stat record. This function examines every heap block to get the statistics. + **/ + static function stat():Stat; +} \ No newline at end of file diff --git a/std/haxe/ds/Vector.hx b/std/haxe/ds/Vector.hx index 20ddd11dca2..3a38a95a737 100644 --- a/std/haxe/ds/Vector.hx +++ b/std/haxe/ds/Vector.hx @@ -35,6 +35,8 @@ private typedef VectorData = #if flash10 java.NativeArray #elseif lua lua.Table +#elseif eval + eval.Vector #else Array #end @@ -74,6 +76,8 @@ abstract Vector(VectorData) { this = python.Syntax.pythonCode("[{0}]*{1}", null, length); #elseif lua this = untyped __lua_table__({length:length}); + #elseif eval + this = new eval.Vector(length); #else this = []; untyped this.length = length; @@ -91,6 +95,8 @@ abstract Vector(VectorData) { return this.unsafeGet(index); #elseif python return python.internal.ArrayImpl.unsafeGet(this, index); + #elseif eval + return this[index]; #else return this[index]; #end @@ -107,6 +113,8 @@ abstract Vector(VectorData) { return this.unsafeSet(index,val); #elseif python return python.internal.ArrayImpl.unsafeSet(this, index, val); + #elseif eval + return this[index] = val; #else return this[index] = val; #end @@ -138,7 +146,7 @@ abstract Vector(VectorData) { The results are unspecified if `length` results in out-of-bounds access, or if `src` or `dest` are null **/ - public static #if (cs || java || neko || cpp) inline #end function blit(src:Vector, srcPos:Int, dest:Vector, destPos:Int, len:Int):Void + public static #if (cs || java || neko || cpp || eval) inline #end function blit(src:Vector, srcPos:Int, dest:Vector, destPos:Int, len:Int):Void { #if neko untyped __dollar__ablit(dest,destPos,src,srcPos,len); @@ -148,6 +156,8 @@ abstract Vector(VectorData) { cs.system.Array.Copy(cast src, srcPos,cast dest, destPos, len); #elseif cpp dest.toData().blit(destPos,src.toData(), srcPos,len); + #elseif eval + src.toData().blit(srcPos, dest.toData(), destPos, len); #else if (src == dest) { if (srcPos < destPos) { @@ -178,13 +188,15 @@ abstract Vector(VectorData) { /** Creates a new Array, copy the content from the Vector to it, and returns it. **/ - public #if (flash || cpp || js || java) inline #end function toArray():Array { + public #if (flash || cpp || js || java || eval) inline #end function toArray():Array { #if cpp return this.copy(); #elseif python return this.copy(); #elseif js return this.slice(0); + #elseif eval + return this.toArray(); #else var a = new Array(); var len = length; @@ -241,6 +253,8 @@ abstract Vector(VectorData) { return cast array.copy(); #elseif js return fromData(array.slice(0)); + #elseif eval + return fromData(eval.Vector.fromArrayCopy(array)); #else // TODO: Optimize this for others? var vec = new Vector(array.length); @@ -258,9 +272,13 @@ abstract Vector(VectorData) { `a == a.copy()` is always false. **/ #if cs @:extern #end public inline function copy():Vector { + #if eval + return fromData(this.copy()); + #else var r = new Vector(length); Vector.blit(cast this, 0, r, 0, length); return r; + #end } /** @@ -277,7 +295,7 @@ abstract Vector(VectorData) { If `sep` is null, the result is unspecified. **/ #if cs @:extern #end public inline function join(sep:String):String { - #if (flash10||cpp) + #if (flash10 || cpp || eval) return this.join(sep); #else var b = new StringBuf(); @@ -301,6 +319,9 @@ abstract Vector(VectorData) { If `f` is null, the result is unspecified. **/ #if cs @:extern #end public inline function map(f:T->S):Vector { + #if eval + return fromData(this.map(f)); + #else var length = length; var r = new Vector(length); var i = 0; @@ -310,6 +331,7 @@ abstract Vector(VectorData) { r.set(i, v); } return r; + #end } /** @@ -325,7 +347,7 @@ abstract Vector(VectorData) { If `f` is null, the result is unspecified. **/ public inline function sort(f:T->T->Int):Void { - #if (neko || cs || java) + #if (neko || cs || java || eval) throw "not yet supported"; #elseif lua haxe.ds.ArraySort.sort(cast this, f); diff --git a/tests/benchs/mandelbrot/compile-hl.hxml b/tests/benchs/mandelbrot/compile-hl.hxml new file mode 100644 index 00000000000..4693f04d17d --- /dev/null +++ b/tests/benchs/mandelbrot/compile-hl.hxml @@ -0,0 +1,9 @@ +-main Mandelbrot +-hl bin/mandelbrot.hl +-D interp + +--next +-main Mandelbrot +-hl bin/mandelbrot-anon.hl +-D interp +-D anon_objects \ No newline at end of file diff --git a/tests/benchs/mandelbrot/compile-macro.hxml b/tests/benchs/mandelbrot/compile-macro.hxml new file mode 100644 index 00000000000..d39c9f06c84 --- /dev/null +++ b/tests/benchs/mandelbrot/compile-macro.hxml @@ -0,0 +1,7 @@ +-main Mandelbrot +--interp + +--next +-main Mandelbrot +--interp +-D anon_objects \ No newline at end of file diff --git a/tests/unit/src/unit/issues/Issue5155.hx b/tests/unit/src/unit/issues/Issue5155.hx new file mode 100644 index 00000000000..e3d255143f1 --- /dev/null +++ b/tests/unit/src/unit/issues/Issue5155.hx @@ -0,0 +1,13 @@ +package unit.issues; + +class Issue5155 extends unit.Test { + public function toString () { + var full = Type.getClassName(Type.getClass(this)); + var short = full.split (".").pop (); + return "[object " + short + "]"; + } + + function test() { + unspec(() -> Type.getClass(this)); + } +} \ No newline at end of file diff --git a/tests/unit/src/unit/issues/Issue5160.hx b/tests/unit/src/unit/issues/Issue5160.hx new file mode 100644 index 00000000000..9e8618f1c63 --- /dev/null +++ b/tests/unit/src/unit/issues/Issue5160.hx @@ -0,0 +1,9 @@ +package unit.issues; + +class Issue5160 extends unit.Test { + function test() { + var bytes = haxe.io.Bytes.alloc(256); + bytes.setInt32(0, -1241956892); + eq(-1241956892, bytes.getInt32(0)); + } +} \ No newline at end of file diff --git a/tests/unit/src/unit/issues/Issue6145.hx b/tests/unit/src/unit/issues/Issue6145.hx new file mode 100644 index 00000000000..2d6289a114b --- /dev/null +++ b/tests/unit/src/unit/issues/Issue6145.hx @@ -0,0 +1,11 @@ +package unit.issues; + +class Issue6145 extends unit.Test { + function test() { + var r = ~/(a)/; + r.match("a"); + #if (!cs && !php) + exc(() -> r.matched(2)); + #end + } +} \ No newline at end of file diff --git a/tests/unit/src/unitstd/haxe/ds/Vector.unit.hx b/tests/unit/src/unitstd/haxe/ds/Vector.unit.hx index 8eed5327d81..ad6b97f7a0a 100644 --- a/tests/unit/src/unitstd/haxe/ds/Vector.unit.hx +++ b/tests/unit/src/unitstd/haxe/ds/Vector.unit.hx @@ -2,7 +2,6 @@ var vec = new haxe.ds.Vector(3); var vNullInt = #if (flash || cpp || java || cs || hl) 0 #else null #end; var vNullBool = #if (flash || cpp || java || cs || hl) false #else null #end; var vNullFloat = #if (flash || cpp || java || cs || hl) 0.0 #else null #end; - vec.length == 3; vec.get(0) == vNullInt; vec.get(1) == vNullInt; @@ -31,7 +30,7 @@ vec.get(2) == vNullBool; // fromArray var arr = ["1", "2", "3"]; var vec:haxe.ds.Vector = haxe.ds.Vector.fromArrayCopy(arr); -#if (!flash && !neko && !cs && !java && !lua) +#if (!flash && !neko && !cs && !java && !lua && !eval) arr != vec.toData(); #end vec.length == 3; @@ -174,7 +173,7 @@ vec2[1] == "value: 13"; // sort -#if !(neko || cs || java) +#if !(neko || cs || java || eval) var vec = new haxe.ds.Vector(4); vec[0] = 99; vec[1] = 101;