Rework internal frontend (#10629)

* reorganize compiler/server frontend

* try some piping

see #9359

* clean up some more

* try to get subprocess piping right

* actually we need the shell...

* hold back on pipe changes because this isn't working right

* move some more stuff around

* a little more

* try to dodge for now

* try something

* some more cleanup

* $currentyear

skip ci

src/compiler/args.ml

@@ -0,0 +1,437 @@
+open Globals
+open Common
+open CompilationContext
+
+let limit_string s offset =
+	let rest = 80 - offset in
+	let words = ExtString.String.nsplit s " " in
+	let rec loop i words = match words with
+		| word :: words ->
+			if String.length word + i + 1 > rest then (Printf.sprintf "\n%*s" offset "") :: word :: loop (String.length word) words
+			else (if i = 0 then "" else " ") :: word :: loop (i + 1 + String.length word) words
+		| [] ->
+			[]
+	in
+	String.concat "" (loop 0 words)
+
+let usage_string ?(print_cat=true) arg_spec usage =
+	let make_label = fun names hint -> Printf.sprintf "%s %s" (String.concat ", " names) hint in
+	let args = (List.filter (fun (cat, ok, dep, spec, hint, doc) -> (List.length ok) > 0) arg_spec) in
+	let cat_order = ["Target";"Compilation";"Optimization";"Debug";"Batch";"Services";"Compilation Server";"Target-specific";"Miscellaneous"] in
+	let cats = List.filter (fun x -> List.mem x (List.map (fun (cat, _, _, _, _, _) -> cat) args)) cat_order in
+	let max_length = List.fold_left max 0 (List.map String.length (List.map (fun (_, ok, _, _, hint, _) -> make_label ok hint) args)) in
+	usage ^ (String.concat "\n" (List.flatten (List.map (fun cat -> (if print_cat then ["\n"^cat^":"] else []) @ (List.map (fun (cat, ok, dep, spec, hint, doc) ->
+		let label = make_label ok hint in
+		Printf.sprintf "  %s%s  %s" label (String.make (max_length - (String.length label)) ' ') doc
+	) (List.filter (fun (cat', _, _, _, _, _) -> (if List.mem cat' cat_order then cat' else "Miscellaneous") = cat) args))) cats)))
+
+let add_libs com libs =
+	let global_repo = List.exists (fun a -> a = "--haxelib-global") com.args in
+	let call_haxelib() =
+		let t = Timer.timer ["haxelib"] in
+		let cmd = "haxelib" ^ (if global_repo then " --global" else "") ^ " path " ^ String.concat " " libs in
+		let pin, pout, perr = Unix.open_process_full cmd (Unix.environment()) in
+		let lines = Std.input_list pin in
+		let err = Std.input_list perr in
+		let ret = Unix.close_process_full (pin,pout,perr) in
+		if ret <> Unix.WEXITED 0 then failwith (match lines, err with
+			| [], [] -> "Failed to call haxelib (command not found ?)"
+			| [], [s] when ExtString.String.ends_with (ExtString.String.strip s) "Module not found: path" -> "The haxelib command has been strip'ed, please install it again"
+			| _ -> String.concat "\n" (lines@err));
+		t();
+		lines
+	in
+	match libs with
+	| [] -> []
+	| _ ->
+		let lines = match CompilationServer.get() with
+			| Some cs ->
+				(try
+					(* if we are compiling, really call haxelib since library path might have changed *)
+					if not com.display.dms_display then raise Not_found;
+					cs#find_haxelib libs
+				with Not_found ->
+					let lines = call_haxelib() in
+					cs#cache_haxelib libs lines;
+					lines)
+			| _ -> call_haxelib()
+		in
+		let extra_args = ref [] in
+		let lines = List.fold_left (fun acc l ->
+			let l = ExtString.String.strip l in
+			if l = "" then acc else
+			if l.[0] <> '-' then l :: acc else
+			match (try ExtString.String.split l " " with _ -> l, "") with
+			| ("-L",dir) ->
+				com.neko_libs <- String.sub l 3 (String.length l - 3) :: com.neko_libs;
+				acc
+			| param, value ->
+				extra_args := param :: !extra_args;
+				if value <> "" then extra_args := value :: !extra_args;
+				acc
+		) [] lines in
+		com.class_path <- lines @ com.class_path;
+		List.rev !extra_args
+
+let process_args arg_spec =
+	(* Takes a list of arg specs including some custom info, and generates a
+	list in the format Arg.parse_argv wants. Handles multiple official or
+	deprecated names for the same arg; deprecated versions will display a
+	warning. *)
+	List.flatten(List.map (fun (cat, ok, dep, spec, hint, doc) ->
+		(* official argument names *)
+		(List.map (fun (arg) -> (arg, spec, doc)) ok) @
+		(* deprecated argument names *)
+		(* let dep_msg arg = (Printf.sprintf "WARNING: %s is deprecated" arg) ^ (if List.length ok > 0 then (Printf.sprintf ". Use %s instead" (String.concat "/" ok)) else "") in *)
+		(* For now, these warnings are a noop. Can replace this function to
+		enable error output: *)
+		(* let dep_fun = prerr_endline (dep_msg arg) in *)
+		let dep_fun arg spec = () in
+		let dep_spec arg spec = match spec with
+			| Arg.String f -> Arg.String (fun x -> dep_fun arg spec; f x)
+			| Arg.Unit f -> Arg.Unit (fun x -> dep_fun arg spec; f x)
+			| Arg.Bool f -> Arg.Bool (fun x -> dep_fun arg spec; f x)
+			| _ -> spec in
+		(List.map (fun (arg) -> (arg, dep_spec arg spec, doc)) dep)
+	) arg_spec)
+
+let parse_args com =
+	let usage = Printf.sprintf
+		"Haxe Compiler %s - (C)2005-2022 Haxe Foundation\nUsage: haxe%s <target> [options] [hxml files and dot paths...]\n"
+		s_version_full (if Sys.os_type = "Win32" then ".exe" else "")
+	in
+	let actx = {
+		classes = [([],"Std")];
+		xml_out = None;
+		json_out = None;
+		swf_header = None;
+		cmds = [];
+		config_macros = [];
+		cp_libs = [];
+		added_libs = Hashtbl.create 0;
+		no_output = false;
+		did_something = false;
+		force_typing = false;
+		pre_compilation = [];
+		interp = false;
+		jvm_flag = false;
+		swf_version = false;
+		native_libs = [];
+		raise_usage = (fun () -> ());
+		server_mode = SMNone;
+	} in
+	let add_native_lib file extern = actx.native_libs <- (file,extern) :: actx.native_libs in
+	let define f = Arg.Unit (fun () -> Common.define com f) in
+	let process_ref = ref (fun args -> ()) in
+	let process_libs() =
+		let libs = List.filter (fun l -> not (Hashtbl.mem actx.added_libs l)) (List.rev actx.cp_libs) in
+		actx.cp_libs <- [];
+		List.iter (fun l -> Hashtbl.add actx.added_libs l ()) libs;
+		(* immediately process the arguments to insert them at the place -lib was defined *)
+		match add_libs com libs with
+		| [] -> ()
+		| args -> (!process_ref) args
+	in
+	(* category, official names, deprecated names, arg spec, usage hint, doc *)
+	let basic_args_spec = [
+		("Target",["--js"],["-js"],Arg.String (set_platform com Js),"<file>","generate JavaScript code into target file");
+		("Target",["--lua"],["-lua"],Arg.String (set_platform com Lua),"<file>","generate Lua code into target file");
+		("Target",["--swf"],["-swf"],Arg.String (set_platform com Flash),"<file>","generate Flash SWF bytecode into target file");
+		("Target",["--neko"],["-neko"],Arg.String (set_platform com Neko),"<file>","generate Neko bytecode into target file");
+		("Target",["--php"],["-php"],Arg.String (fun dir ->
+			actx.classes <- (["php"],"Boot") :: actx.classes;
+			set_platform com Php dir;
+		),"<directory>","generate PHP code into target directory");
+		("Target",["--cpp"],["-cpp"],Arg.String (fun dir ->
+			set_platform com Cpp dir;
+		),"<directory>","generate C++ code into target directory");
+		("Target",["--cppia"],["-cppia"],Arg.String (fun file ->
+			Common.define com Define.Cppia;
+			set_platform com Cpp file;
+		),"<file>","generate Cppia bytecode into target file");
+		("Target",["--cs"],["-cs"],Arg.String (fun dir ->
+			actx.cp_libs <- "hxcs" :: actx.cp_libs;
+			set_platform com Cs dir;
+		),"<directory>","generate C# code into target directory");
+		("Target",["--java"],["-java"],Arg.String (fun dir ->
+			actx.cp_libs <- "hxjava" :: actx.cp_libs;
+			set_platform com Java dir;
+		),"<directory>","generate Java code into target directory");
+		("Target",["--jvm"],[],Arg.String (fun dir ->
+			actx.cp_libs <- "hxjava" :: actx.cp_libs;
+			Common.define com Define.Jvm;
+			actx.jvm_flag <- true;
+			set_platform com Java dir;
+		),"<file>","generate JVM bytecode into target file");
+		("Target",["--python"],["-python"],Arg.String (fun dir ->
+			set_platform com Python dir;
+		),"<file>","generate Python code into target file");
+		("Target",["--hl"],["-hl"],Arg.String (fun file ->
+			set_platform com Hl file;
+		),"<file>","generate HashLink .hl bytecode or .c code into target file");
+		("Target",[],["-x"], Arg.String (fun cl ->
+			let cpath = Path.parse_type_path cl in
+			(match com.main_class with
+				| Some c -> if cpath <> c then raise (Arg.Bad "Multiple --main classes specified")
+				| None -> com.main_class <- Some cpath);
+			actx.classes <- cpath :: actx.classes;
+			Common.define com Define.Interp;
+			set_platform com (!Globals.macro_platform) "";
+			actx.interp <- true;
+		),"<class>","interpret the program using internal macro system");
+		("Target",["--interp"],[], Arg.Unit (fun() ->
+			Common.define com Define.Interp;
+			set_platform com (!Globals.macro_platform) "";
+			actx.interp <- true;
+		),"","interpret the program using internal macro system");
+		("Target",["--run"],[], Arg.Unit (fun() ->
+			raise (Arg.Bad "--run requires an argument: a Haxe module name")
+		), "<module> [args...]","interpret a Haxe module with command line arguments");
+		("Compilation",["-p";"--class-path"],["-cp"],Arg.String (fun path ->
+			process_libs();
+			com.class_path <- Path.add_trailing_slash path :: com.class_path
+		),"<path>","add a directory to find source files");
+		("Compilation",["-m";"--main"],["-main"],Arg.String (fun cl ->
+			if com.main_class <> None then raise (Arg.Bad "Multiple --main classes specified");
+			let cpath = Path.parse_type_path cl in
+			com.main_class <- Some cpath;
+			actx.classes <- cpath :: actx.classes
+		),"<class>","select startup class");
+		("Compilation",["-L";"--library"],["-lib"],Arg.String (fun l ->
+			actx.cp_libs <- l :: actx.cp_libs;
+			Common.external_define com l;
+		),"<name[:ver]>","use a haxelib library");
+		("Compilation",["-D";"--define"],[],Arg.String (fun var ->
+			let flag, value = try let split = ExtString.String.split var "=" in (fst split, Some (snd split)) with _ -> var, None in
+			match value with
+				| Some value -> Common.external_define_value com flag value
+				| None -> Common.external_define com flag;
+		),"<var[=value]>","define a conditional compilation flag");
+		("Debug",["-v";"--verbose"],[],Arg.Unit (fun () ->
+			com.verbose <- true
+		),"","turn on verbose mode");
+		("Debug",["--debug"],["-debug"], Arg.Unit (fun() ->
+			Common.define com Define.Debug;
+			com.debug <- true;
+		),"","add debug information to the compiled code");
+		("Miscellaneous",["--version"],["-version"],Arg.Unit (fun() ->
+			com.info s_version_full null_pos;
+			actx.did_something <- true;
+		),"","print version and exit");
+		("Miscellaneous", ["-h";"--help"], ["-help"], Arg.Unit (fun () ->
+			raise (Arg.Help "")
+		),"","show extended help information");
+		("Miscellaneous",["--help-defines"],[], Arg.Unit (fun() ->
+			let all,max_length = Define.get_documentation_list() in
+			let all = List.map (fun (n,doc) -> Printf.sprintf " %-*s: %s" max_length n (limit_string doc (max_length + 3))) all in
+			List.iter (fun msg -> com.print (msg ^ "\n")) all;
+			actx.did_something <- true
+		),"","print help for all compiler specific defines");
+		("Miscellaneous",["--help-metas"],[], Arg.Unit (fun() ->
+			let all,max_length = Meta.get_documentation_list() in
+			let all = List.map (fun (n,doc) -> Printf.sprintf " %-*s: %s" max_length n (limit_string doc (max_length + 3))) all in
+			List.iter (fun msg -> com.print (msg ^ "\n")) all;
+			actx.did_something <- true
+		),"","print help for all compiler metadatas");
+	] in
+	let adv_args_spec = [
+		("Optimization",["--dce"],["-dce"],Arg.String (fun mode ->
+			(match mode with
+			| "std" | "full" | "no" -> ()
+			| _ -> raise (Arg.Bad "Invalid DCE mode, expected std | full | no"));
+			Common.define_value com Define.Dce mode
+		),"[std|full|no]","set the dead code elimination mode (default std)");
+		("Target-specific",["--swf-version"],["-swf-version"],Arg.Float (fun v ->
+			if not actx.swf_version || com.flash_version < v then com.flash_version <- v;
+			actx.swf_version <- true;
+		),"<version>","change the SWF version");
+		(* FIXME: replace with -D define *)
+		("Target-specific",["--swf-header"],["-swf-header"],Arg.String (fun h ->
+			try
+				actx.swf_header <- Some (match ExtString.String.nsplit h ":" with
+				| [width; height; fps] ->
+					(int_of_string width,int_of_string height,float_of_string fps,0xFFFFFF)
+				| [width; height; fps; color] ->
+					let color = if ExtString.String.starts_with color "0x" then color else "0x" ^ color in
+					(int_of_string width, int_of_string height, float_of_string fps, int_of_string color)
+				| _ -> raise Exit)
+			with
+				_ -> raise (Arg.Bad "Invalid SWF header format, expected width:height:fps[:color]")
+		),"<header>","define SWF header (width:height:fps:color)");
+		("Target-specific",["--flash-strict"],[], define Define.FlashStrict, "","more type strict flash API");
+		("Target-specific",["--swf-lib"],["-swf-lib"],Arg.String (fun file ->
+			process_libs(); (* linked swf order matters, and lib might reference swf as well *)
+			add_native_lib file false;
+		),"<file>","add the SWF library to the compiled SWF");
+		(* FIXME: replace with -D define *)
+		("Target-specific",["--swf-lib-extern"],["-swf-lib-extern"],Arg.String (fun file ->
+			add_native_lib file true;
+		),"<file>","use the SWF library for type checking");
+		("Target-specific",["--java-lib"],["-java-lib"],Arg.String (fun file ->
+			add_native_lib file false;
+		),"<file>","add an external JAR or directory of JAR files");
+		("Target-specific",["--java-lib-extern"],[],Arg.String (fun file ->
+			add_native_lib file true;
+		),"<file>","use an external JAR or directory of JAR files for type checking");
+		("Target-specific",["--net-lib"],["-net-lib"],Arg.String (fun file ->
+			add_native_lib file false;
+		),"<file>[@std]","add an external .NET DLL file");
+		("Target-specific",["--net-std"],["-net-std"],Arg.String (fun file ->
+			Dotnet.add_net_std com file
+		),"<file>","add a root std .NET DLL search path");
+		(* FIXME: replace with -D define *)
+		("Target-specific",["--c-arg"],["-c-arg"],Arg.String (fun arg ->
+			com.c_args <- arg :: com.c_args
+		),"<arg>","pass option <arg> to the native Java/C# compiler");
+		("Compilation",["-r";"--resource"],["-resource"],Arg.String (fun res ->
+			let file, name = (match ExtString.String.nsplit res "@" with
+				| [file; name] -> file, name
+				| [file] -> file, file
+				| _ -> raise (Arg.Bad "Invalid Resource format, expected file@name")
+			) in
+			let file = (try Common.find_file com file with Not_found -> file) in
+			let data = (try
+				let s = Std.input_file ~bin:true file in
+				if String.length s > 12000000 then raise Exit;
+				s;
+			with
+				| Sys_error _ -> failwith ("Resource file not found: " ^ file)
+				| _ -> failwith ("Resource '" ^ file ^ "' excess the maximum size of 12MB")
+			) in
+			if Hashtbl.mem com.resources name then failwith ("Duplicate resource name " ^ name);
+			Hashtbl.add com.resources name data
+		),"<file>[@name]","add a named resource file");
+		("Debug",["--prompt"],["-prompt"], Arg.Unit (fun() -> Helper.prompt := true),"","prompt on error");
+		("Compilation",["--cmd"],["-cmd"], Arg.String (fun cmd ->
+			actx.cmds <- DisplayOutput.unquote cmd :: actx.cmds
+		),"<command>","run the specified command after successful compilation");
+		(* FIXME: replace with -D define *)
+		("Optimization",["--no-traces"],[], define Define.NoTraces, "","don't compile trace calls in the program");
+		("Batch",["--next"],[], Arg.Unit (fun() -> die "" __LOC__), "","separate several haxe compilations");
+		("Batch",["--each"],[], Arg.Unit (fun() -> die "" __LOC__), "","append preceding parameters to all Haxe compilations separated by --next");
+		("Services",["--display"],[], Arg.String (fun input ->
+			let input = String.trim input in
+			if String.length input > 0 && (input.[0] = '[' || input.[0] = '{') then begin
+				actx.did_something <- true;
+				actx.force_typing <- true;
+				DisplayJson.parse_input com input Timer.measure_times
+			end else
+				DisplayOutput.handle_display_argument com input actx;
+		),"","display code tips");
+		("Services",["--xml"],["-xml"],Arg.String (fun file ->
+			actx.xml_out <- Some file
+		),"<file>","generate XML types description");
+		("Services",["--json"],[],Arg.String (fun file ->
+			actx.json_out <- Some file
+		),"<file>","generate JSON types description");
+		("Optimization",["--no-output"],[], Arg.Unit (fun() -> actx.no_output <- true),"","compiles but does not generate any file");
+		("Debug",["--times"],[], Arg.Unit (fun() -> Timer.measure_times := true),"","measure compilation times");
+		("Optimization",["--no-inline"],[], define Define.NoInline, "","disable inlining");
+		("Optimization",["--no-opt"],[], Arg.Unit (fun() ->
+			com.foptimize <- false;
+			Common.define com Define.NoOpt;
+		), "","disable code optimizations");
+		("Compilation",["--remap"],[], Arg.String (fun s ->
+			let pack, target = (try ExtString.String.split s ":" with _ -> raise (Arg.Bad "Invalid remap format, expected source:target")) in
+			com.package_rules <- PMap.add pack (Remap target) com.package_rules;
+		),"<package:target>","remap a package to another one");
+		("Compilation",["--macro"],[], Arg.String (fun e ->
+			actx.force_typing <- true;
+			actx.config_macros <- e :: actx.config_macros
+		),"<macro>","call the given macro before typing anything else");
+		("Compilation Server",["--server-listen"],["--wait"], Arg.String (fun hp ->
+			actx.server_mode <- SMListen hp;
+		),"[[host:]port]|stdio]","wait on the given port (or use standard i/o) for commands to run");
+		("Compilation Server",["--server-connect"],[], Arg.String (fun hp ->
+			actx.server_mode <- SMConnect hp;
+		),"[host:]port]","connect to the given port and wait for commands to run");
+		("Compilation Server",["--connect"],[],Arg.String (fun _ ->
+			die "" __LOC__
+		),"<[host:]port>","connect on the given port and run commands there");
+		("Compilation",["-C";"--cwd"],[], Arg.String (fun dir ->
+			(try Unix.chdir dir with _ -> raise (Arg.Bad ("Invalid directory: " ^ dir)));
+			actx.did_something <- true;
+		),"<directory>","set current working directory");
+		("Compilation",["--haxelib-global"],[], Arg.Unit (fun () -> ()),"","pass --global argument to haxelib");
+		("Compilation",["-w"],[], Arg.String (fun s ->
+			let p = { pfile = "-w " ^ s; pmin = 0; pmax = 0 } in
+			let l = Warning.parse_options s p in
+			com.warning_options <- l :: com.warning_options
+		),"<warning list>","enable or disable specific warnings");
+	] in
+	let args_callback cl =
+		begin try
+			let path,name = Path.parse_path cl in
+			if StringHelper.starts_uppercase_identifier name then
+				actx.classes <- (path,name) :: actx.classes
+			else begin
+				actx.force_typing <- true;
+				actx.config_macros <- (Printf.sprintf "include('%s', true, null, null, true)" cl) :: actx.config_macros;
+			end
+		with Failure _ when com.display.dms_display ->
+			()
+		end
+	in
+	let all_args = (basic_args_spec @ adv_args_spec) in
+	let all_args_spec = process_args all_args in
+	let process args =
+		let current = ref 0 in
+		(try
+			let rec loop acc args = match args with
+				| "--display" :: arg :: args ->
+					loop (arg :: "--display" :: acc) args
+				| arg :: args ->
+					loop (Helper.expand_env arg :: acc) args
+				| [] ->
+					List.rev acc
+			in
+			let args = loop [] args in
+			Arg.parse_argv ~current (Array.of_list ("" :: args)) all_args_spec args_callback "";
+		with
+		| Arg.Help _ ->
+			raise (Helper.HelpMessage (usage_string all_args usage))
+		| Arg.Bad msg ->
+			let first_line = List.nth (Str.split (Str.regexp "\n") msg) 0 in
+			let new_msg = (Printf.sprintf "%s" first_line) in
+			let r = Str.regexp "unknown option [`']?\\([-A-Za-z]+\\)[`']?" in
+			try
+				ignore(Str.search_forward r msg 0);
+				let s = Str.matched_group 1 msg in
+				let sl = List.map (fun (s,_,_) -> s) all_args_spec in
+				let sl = StringError.get_similar s sl in
+				begin match sl with
+				| [] -> raise Not_found
+				| _ ->
+					let spec = List.filter (fun (_,sl',sl'',_,_,_) ->
+						List.exists (fun s -> List.mem s sl) (sl' @ sl'')
+					) all_args in
+					let new_msg = (Printf.sprintf "%s\nDid you mean:\n%s" first_line (usage_string ~print_cat:false spec "")) in
+					raise (Arg.Bad new_msg)
+				end;
+			with Not_found ->
+				raise (Arg.Bad new_msg));
+		if com.platform = Globals.Cpp && not (Define.defined com.defines DisableUnicodeStrings) && not (Define.defined com.defines HxcppSmartStings) then begin
+			Define.define com.defines HxcppSmartStings;
+		end;
+		if Define.raw_defined com.defines "gen_hx_classes" then begin
+			(* TODO: this is something we're gonna remove once we have something nicer for generating flash externs *)
+			actx.force_typing <- true;
+			actx.pre_compilation <- (fun() ->
+				let process_lib lib =
+					if not (lib#has_flag NativeLibraries.FlagIsStd) then
+						List.iter (fun path -> if path <> (["java";"lang"],"String") then actx.classes <- path :: actx.classes) lib#list_modules
+				in
+				List.iter process_lib com.native_libs.net_libs;
+				List.iter process_lib com.native_libs.swf_libs;
+				List.iter process_lib com.native_libs.java_libs;
+			) :: actx.pre_compilation;
+			actx.xml_out <- Some "hx"
+		end;
+	in
+	actx.raise_usage <- (fun () -> raise (Helper.HelpMessage (usage_string basic_args_spec usage)));
+	process_ref := process;
+	(* Handle CLI arguments *)
+	process com.args;
+	(* Process haxelibs *)
+	process_libs();
+	actx

src/compiler/compilationContext.ml

@@ -0,0 +1,54 @@
+open Globals
+
+type server_mode =
+	| SMNone
+	| SMListen of string
+	| SMConnect of string
+
+type arg_context = {
+	mutable classes : Globals.path list;
+	mutable xml_out : string option;
+	mutable json_out : string option;
+	mutable swf_header : (int * int * float * int) option;
+	mutable cmds : string list;
+	mutable config_macros : string list;
+	mutable cp_libs : string list;
+	added_libs : (string,unit) Hashtbl.t;
+	mutable no_output : bool;
+	mutable did_something : bool;
+	mutable force_typing : bool;
+	mutable pre_compilation : (unit -> unit) list;
+	mutable interp : bool;
+	mutable jvm_flag : bool;
+	mutable swf_version : bool;
+	mutable native_libs : (string * bool) list;
+	mutable raise_usage : unit -> unit;
+	mutable server_mode : server_mode;
+}
+
+type communication = {
+	write_out : string -> unit;
+	write_err : string -> unit;
+	flush     : compilation_context -> unit;
+	is_server : bool;
+}
+
+and compilation_context = {
+	com : Common.context;
+	mutable on_exit : (unit -> unit) list;
+	mutable messages : Common.compiler_message list;
+	mutable has_next : bool;
+	mutable has_error : bool;
+	comm : communication;
+}
+
+type server_accept = unit -> (bool * (bool -> string option) * (string -> unit) * (unit -> unit))
+
+type server_api = {
+	setup_new_context : Common.context -> unit;
+	init_wait_socket : string -> int -> server_accept;
+	init_wait_connect : string -> int -> server_accept;
+	init_wait_stdio : unit -> server_accept;
+	wait_loop : bool -> server_accept -> unit;
+	do_connect : string -> int -> string list -> unit;
+}

src/compiler/compiler.ml

@@ -0,0 +1,816 @@
+open Extlib_leftovers
+open Globals
+open Common
+open CompilationContext
+open Type
+open DisplayException
+open DisplayTypes.CompletionResultKind
+
+exception Abort
+
+let message ctx msg =
+	ctx.messages <- msg :: ctx.messages
+
+let error ctx msg p =
+	message ctx (CMError(msg,p));
+	ctx.has_error <- true
+
+let delete_file f = try Sys.remove f with _ -> ()
+
+let initialize_target ctx com actx =
+	let add_std dir =
+		com.class_path <- List.filter (fun s -> not (List.mem s com.std_path)) com.class_path @ List.map (fun p -> p ^ dir ^ "/_std/") com.std_path @ com.std_path
+	in
+	match com.platform with
+		| Cross ->
+			(* no platform selected *)
+			set_platform com Cross "";
+			"?"
+		| Flash ->
+			let rec loop = function
+				| [] -> ()
+				| (v,_) :: _ when v > com.flash_version -> ()
+				| (v,def) :: l ->
+					Common.raw_define com ("flash" ^ def);
+					loop l
+			in
+			loop Common.flash_versions;
+			com.package_rules <- PMap.remove "flash" com.package_rules;
+			add_std "flash";
+			"swf"
+		| Neko ->
+			add_std "neko";
+			"n"
+		| Js ->
+			let es_version =
+				try
+					int_of_string (Common.defined_value com Define.JsEs)
+				with
+				| Not_found ->
+					(Common.define_value com Define.JsEs "5"; 5)
+				| _ ->
+					0
+			in
+
+			if es_version < 3 || es_version = 4 then (* we don't support ancient and there's no 4th *)
+				failwith "Invalid -D js-es value";
+
+			if es_version >= 5 then Common.raw_define com "js_es5"; (* backward-compatibility *)
+
+			add_std "js";
+			"js"
+		| Lua ->
+			add_std "lua";
+			"lua"
+		| Php ->
+			add_std "php";
+			"php"
+		| Cpp ->
+			Common.define_value com Define.HxcppApiLevel "430";
+			add_std "cpp";
+			if Common.defined com Define.Cppia then
+				actx.classes <- (Path.parse_path "cpp.cppia.HostClasses" ) :: actx.classes;
+			"cpp"
+		| Cs ->
+			ctx.on_exit <- (fun () ->
+				com.native_libs.net_libs <- [];
+			) :: ctx.on_exit;
+			Dotnet.before_generate com;
+			add_std "cs"; "cs"
+		| Java ->
+			ctx.on_exit <- (fun () ->
+				List.iter (fun java_lib -> java_lib#close) com.native_libs.java_libs;
+				com.native_libs.java_libs <- [];
+			) :: ctx.on_exit;
+			Java.before_generate com;
+			if defined com Define.Jvm then begin
+				add_std "jvm";
+				com.package_rules <- PMap.remove "jvm" com.package_rules;
+			end;
+			add_std "java";
+			"java"
+		| Python ->
+			add_std "python";
+			if not (Common.defined com Define.PythonVersion) then
+				Common.define_value com Define.PythonVersion "3.3";
+			"python"
+		| Hl ->
+			add_std "hl";
+			if not (Common.defined com Define.HlVer) then Define.define_value com.defines Define.HlVer (try Std.input_file (Common.find_file com "hl/hl_version") with Not_found -> die "" __LOC__);
+			"hl"
+		| Eval ->
+			add_std "eval";
+			"eval"
+
+let process_display_configuration ctx =
+	let com = ctx.com in
+	if com.display.dms_kind <> DMNone then begin
+		com.warning <-
+			if com.display.dms_error_policy = EPCollect then
+				(fun w options s p ->
+					match Warning.get_mode w (com.warning_options @ options) with
+					| WMEnable ->
+						add_diagnostics_message com s p DKCompilerError DisplayTypes.DiagnosticsSeverity.Warning
+					| WMDisable ->
+						()
+				)
+			else
+				(fun w options msg p ->
+					match Warning.get_mode w (com.warning_options @ options) with
+					| WMEnable ->
+						message ctx (CMWarning(msg,p))
+					| WMDisable ->
+						()
+				);
+		com.error <- error ctx;
+	end;
+	Lexer.old_format := Common.defined com Define.OldErrorFormat;
+	if !Lexer.old_format && !Parser.in_display then begin
+		let p = DisplayPosition.display_position#get in
+		(* convert byte position to utf8 position *)
+		try
+			let content = Std.input_file ~bin:true (Path.get_real_path p.pfile) in
+			let pos = UTF8.length (String.sub content 0 p.pmin) in
+			DisplayPosition.display_position#set { p with pmin = pos; pmax = pos }
+		with _ ->
+			() (* ignore *)
+	end
+
+let create_typer_context ctx native_libs =
+	let com = ctx.com in
+	Common.log com ("Classpath: " ^ (String.concat ";" com.class_path));
+	let buffer = Buffer.create 64 in
+	Buffer.add_string buffer "Defines: ";
+	PMap.iter (fun k v -> match v with
+		| "1" -> Printf.bprintf buffer "%s;" k
+		| _ -> Printf.bprintf buffer "%s=%s;" k v
+	) com.defines.values;
+	Buffer.truncate buffer (Buffer.length buffer - 1);
+	Common.log com (Buffer.contents buffer);
+	Typecore.type_expr_ref := (fun ?(mode=MGet) ctx e with_type -> Typer.type_expr ~mode ctx e with_type);
+	List.iter (fun f -> f ()) (List.rev com.callbacks#get_before_typer_create);
+	(* Native lib pass 1: Register *)
+	let fl = List.map (fun (file,extern) -> NativeLibraryHandler.add_native_lib com file extern) (List.rev native_libs) in
+	(* Native lib pass 2: Initialize *)
+	List.iter (fun f -> f()) fl;
+	Typer.create com
+
+let load_display_module_in_macro tctx display_file_dot_path clear = match display_file_dot_path with
+	| Some cpath ->
+		let p = null_pos in
+		begin try
+			let open Typecore in
+			let _, mctx = MacroContext.get_macro_context tctx p in
+			(* Tricky stuff: We want to remove the module from our lookups and load it again in
+				display mode. This covers some cases like --macro typing it in non-display mode (issue #7017). *)
+			if clear then begin
+				begin try
+					let m = Hashtbl.find mctx.g.modules cpath in
+					Hashtbl.remove mctx.g.modules cpath;
+					Hashtbl.remove mctx.g.types_module cpath;
+					List.iter (fun mt ->
+						let ti = t_infos mt in
+						Hashtbl.remove mctx.g.modules ti.mt_path;
+						Hashtbl.remove mctx.g.types_module ti.mt_path;
+					) m.m_types
+				with Not_found ->
+					()
+				end;
+			end;
+			let _ = MacroContext.load_macro_module tctx cpath true p in
+			Finalization.finalize mctx;
+			Some mctx
+		with DisplayException _ | Parser.TypePath _ as exc ->
+			raise exc
+		| _ ->
+			None
+		end
+	| None ->
+		None
+
+let run_or_diagnose com f arg =
+	let handle_diagnostics msg p kind =
+		add_diagnostics_message com msg p kind DisplayTypes.DiagnosticsSeverity.Error;
+		Diagnostics.run com;
+	in
+	match com.display.dms_kind with
+	| DMDiagnostics _ ->
+		begin try
+			f arg
+		with
+		| Error.Error(msg,p) ->
+			handle_diagnostics (Error.error_msg msg) p DisplayTypes.DiagnosticsKind.DKCompilerError
+		| Parser.Error(msg,p) ->
+			handle_diagnostics (Parser.error_msg msg) p DisplayTypes.DiagnosticsKind.DKParserError
+		| Lexer.Error(msg,p) ->
+			handle_diagnostics (Lexer.error_msg msg) p DisplayTypes.DiagnosticsKind.DKParserError
+		end
+	| _ ->
+		f arg
+
+(** Creates the typer context and types [classes] into it. *)
+let do_type tctx actx =
+	let com = tctx.Typecore.com in
+	let t = Timer.timer ["typing"] in
+	Option.may (fun cs -> CommonCache.maybe_add_context_sign cs com "before_init_macros") (CompilationServer.get ());
+	com.stage <- CInitMacrosStart;
+	List.iter (MacroContext.call_init_macro tctx) (List.rev actx.config_macros);
+	com.stage <- CInitMacrosDone;
+	CommonCache.lock_signature com "after_init_macros";
+	List.iter (fun f -> f ()) (List.rev com.callbacks#get_after_init_macros);
+	run_or_diagnose com (fun () ->
+		if com.display.dms_kind <> DMNone then Option.may (DisplayTexpr.check_display_file tctx) (CompilationServer.get ());
+		List.iter (fun cpath -> ignore(tctx.Typecore.g.Typecore.do_load_module tctx cpath null_pos)) (List.rev actx.classes);
+		Finalization.finalize tctx;
+	) ();
+	com.stage <- CTypingDone;
+	(* If we are trying to find references, let's syntax-explore everything we know to check for the
+		identifier we are interested in. We then type only those modules that contain the identifier. *)
+	begin match !CompilationServer.instance,com.display.dms_kind with
+		| Some cs,(DMUsage _ | DMImplementation) -> FindReferences.find_possible_references tctx cs;
+		| _ -> ()
+	end;
+	t()
+
+let handle_display ctx tctx display_file_dot_path =
+	let com = ctx.com in
+	if not ctx.com.display.dms_display && ctx.has_error then raise Abort;
+	begin match ctx.com.display.dms_kind,!Parser.delayed_syntax_completion with
+		| DMDefault,Some(kind,subj) -> DisplayOutput.handle_syntax_completion com kind subj
+		| _ -> ()
+	end;
+	if ctx.com.display.dms_exit_during_typing then begin
+		if ctx.has_next || ctx.has_error then raise Abort;
+		(* If we didn't find a completion point, load the display file in macro mode. *)
+		if com.display_information.display_module_has_macro_defines then
+			ignore(load_display_module_in_macro tctx display_file_dot_path true);
+		let no_completion_point_found = "No completion point was found" in
+		match com.json_out with
+		| Some _ -> (match ctx.com.display.dms_kind with
+			| DMDefault -> raise (DisplayException(DisplayFields None))
+			| DMSignature -> raise (DisplayException(DisplaySignatures None))
+			| DMHover -> raise (DisplayException(DisplayHover None))
+			| DMDefinition | DMTypeDefinition -> raise_positions []
+			| _ -> failwith no_completion_point_found)
+		| None ->
+			failwith no_completion_point_found;
+	end
+
+let filter ctx tctx display_file_dot_path =
+	let com = ctx.com in
+	com.stage <- CFilteringStart;
+	let t = Timer.timer ["filters"] in
+	let main, types, modules = run_or_diagnose com Finalization.generate tctx in
+	com.main <- main;
+	com.types <- types;
+	com.modules <- modules;
+	(* Special case for diagnostics: We don't want to load the display file in macro mode because there's a chance it might not be
+		macro-compatible. This means that we might some macro-specific diagnostics, but I don't see what we could do about that. *)
+	let should_load_in_macro = match ctx.com.display.dms_kind with
+		(* Special case for the special case: If the display file has a block which becomes active if `macro` is defined, we can safely
+		   type the module in macro context. (#8682). *)
+		| DMDiagnostics _ -> com.display_information.display_module_has_macro_defines
+		| _ -> true
+	in
+	if ctx.com.display.dms_force_macro_typing && should_load_in_macro then begin
+		match load_display_module_in_macro  tctx display_file_dot_path false with
+		| None -> ()
+		| Some mctx ->
+			(* We don't need a full macro flush here because we're not going to run any macros. *)
+			let _, types, modules = Finalization.generate mctx in
+			mctx.Typecore.com.types <- types;
+			mctx.Typecore.com.Common.modules <- modules
+	end;
+	DisplayOutput.process_global_display_mode com tctx;
+	DeprecationCheck.run com;
+	Filters.run com tctx main;
+	t()
+
+let check_auxiliary_output com actx =
+	begin match actx.xml_out with
+		| None -> ()
+		| Some "hx" ->
+			Genhxold.generate com
+		| Some file ->
+			Common.log com ("Generating xml: " ^ file);
+			Path.mkdir_from_path file;
+			Genxml.generate com file
+	end;
+	begin match actx.json_out with
+		| None -> ()
+		| Some file ->
+			Common.log com ("Generating json : " ^ file);
+			Path.mkdir_from_path file;
+			Genjson.generate com.types file
+	end
+
+let generate tctx ext actx =
+	let com = tctx.Typecore.com in
+	(* check file extension. In case of wrong commandline, we don't want
+		to accidentaly delete a source file. *)
+	if file_extension com.file = ext then delete_file com.file;
+	if com.platform = Flash || com.platform = Cpp || com.platform = Hl then List.iter (Codegen.fix_overrides com) com.types;
+	if Common.defined com Define.Dump then begin
+		Codegen.Dump.dump_types com;
+		Option.may Codegen.Dump.dump_types (com.get_macros())
+	end;
+	if Common.defined com Define.DumpDependencies then begin
+		Codegen.Dump.dump_dependencies com;
+		if not tctx.Typecore.in_macro then match tctx.Typecore.g.Typecore.macros with
+			| None -> ()
+			| Some(_,ctx) -> Codegen.Dump.dump_dependencies ~target_override:(Some "macro") ctx.Typecore.com
+	end;
+	begin match com.platform with
+		| Neko | Hl | Eval when actx.interp -> ()
+		| Cpp when Common.defined com Define.Cppia -> ()
+		| Cpp | Cs | Php -> Path.mkdir_from_path (com.file ^ "/.")
+		| Java when not actx.jvm_flag -> Path.mkdir_from_path (com.file ^ "/.")
+		| _ -> Path.mkdir_from_path com.file
+	end;
+	if actx.interp then
+		Std.finally (Timer.timer ["interp"]) MacroContext.interpret tctx
+	else if com.platform = Cross then
+		()
+	else begin
+		let generate,name = match com.platform with
+		| Flash ->
+			Genswf.generate actx.swf_header,"swf"
+		| Neko ->
+			Genneko.generate,"neko"
+		| Js ->
+			Genjs.generate,"js"
+		| Lua ->
+			Genlua.generate,"lua"
+		| Php ->
+			Genphp7.generate,"php"
+		| Cpp ->
+			Gencpp.generate,"cpp"
+		| Cs ->
+			Gencs.generate,"cs"
+		| Java ->
+			if Common.defined com Jvm then
+				Genjvm.generate actx.jvm_flag,"java"
+			else
+				Genjava.generate,"java"
+		| Python ->
+			Genpy.generate,"python"
+		| Hl ->
+			Genhl.generate,"hl"
+		| Eval ->
+			(fun _ -> MacroContext.interpret tctx),"eval"
+		| Cross ->
+			die "" __LOC__
+		in
+		Common.log com ("Generating " ^ name ^ ": " ^ com.file);
+		let t = Timer.timer ["generate";name] in
+		generate com;
+		t()
+	end
+
+let run_command ctx cmd =
+	let t = Timer.timer ["command"] in
+	(* TODO: this is a hack *)
+	let cmd = if ctx.comm.is_server then begin
+		let h = Hashtbl.create 0 in
+		Hashtbl.add h "__file__" ctx.com.file;
+		Hashtbl.add h "__platform__" (platform_name ctx.com.platform);
+		Helper.expand_env ~h:(Some h) cmd
+	end else
+		cmd
+	in
+	let len = String.length cmd in
+	let result =
+		if len > 3 && String.sub cmd 0 3 = "cd " then begin
+			Sys.chdir (String.sub cmd 3 (len - 3));
+			0
+		(* Emit stderr as a server message in server mode *)
+		end else begin
+			let pout, pin, perr = Unix.open_process_full cmd (Unix.environment()) in
+			let bout = Bytes.create 1024 in
+			let berr = Bytes.create 1024 in
+			let rec read_content channel buf f =
+				begin try
+					let i = input channel buf 0 1024 in
+					if i > 0 then begin
+						f (Bytes.unsafe_to_string (Bytes.sub buf 0 i));
+						read_content channel buf f
+					end
+				with Unix.Unix_error _ ->
+					()
+				end
+			in
+			let tout = Thread.create (fun() -> read_content pout bout ctx.comm.write_out) () in
+			let terr = Thread.create (fun() -> read_content perr berr ctx.comm.write_err) () in
+			Thread.join tout;
+			Thread.join terr;
+			let result = (match Unix.close_process_full (pout,pin,perr) with Unix.WEXITED c | Unix.WSIGNALED c | Unix.WSTOPPED c -> c) in
+			result
+		end
+	in
+	t();
+	result
+
+let executable_path() =
+	Extc.executable_path()
+
+let get_std_class_paths () =
+	try
+		let p = Sys.getenv "HAXE_STD_PATH" in
+		let rec loop = function
+			| drive :: path :: l ->
+				if String.length drive = 1 && ((drive.[0] >= 'a' && drive.[0] <= 'z') || (drive.[0] >= 'A' && drive.[0] <= 'Z')) then
+					(drive ^ ":" ^ path) :: loop l
+				else
+					drive :: loop (path :: l)
+			| l ->
+				l
+		in
+		let parts = Str.split_delim (Str.regexp "[;:]") p in
+		"" :: List.map Path.add_trailing_slash (loop parts)
+	with Not_found ->
+		let base_path = Path.get_real_path (try executable_path() with _ -> "./") in
+		if Sys.os_type = "Unix" then
+			let prefix_path = Filename.dirname base_path in
+			let lib_path = Filename.concat prefix_path "lib" in
+			let share_path = Filename.concat prefix_path "share" in
+			[
+				"";
+				Path.add_trailing_slash (Filename.concat lib_path "haxe/std");
+				Path.add_trailing_slash (Filename.concat lib_path "haxe/extraLibs");
+				Path.add_trailing_slash (Filename.concat share_path "haxe/std");
+				Path.add_trailing_slash (Filename.concat share_path "haxe/extraLibs");
+				Path.add_trailing_slash (Filename.concat base_path "std");
+				Path.add_trailing_slash (Filename.concat base_path "extraLibs")
+			]
+		else
+			[
+				"";
+				Path.add_trailing_slash (Filename.concat base_path "std");
+				Path.add_trailing_slash (Filename.concat base_path "extraLibs")
+			]
+
+let setup_common_context ctx =
+	let com = ctx.com in
+	ctx.com.print <- ctx.comm.write_out;
+	Common.define_value com Define.HaxeVer (Printf.sprintf "%.3f" (float_of_int Globals.version /. 1000.));
+	Common.raw_define com "haxe3";
+	Common.raw_define com "haxe4";
+	Common.define_value com Define.Haxe s_version;
+	Common.raw_define com "true";
+	Common.define_value com Define.Dce "std";
+	com.info <- (fun msg p -> message ctx (CMInfo(msg,p)));
+	com.warning <- (fun w options msg p ->
+		match Warning.get_mode w (com.warning_options @ options) with
+		| WMEnable ->
+			message ctx (CMWarning(msg,p))
+		| WMDisable ->
+			()
+	);
+	com.error <- error ctx;
+	let filter_messages = (fun keep_errors predicate -> (List.filter (fun msg ->
+		(match msg with
+		| CMError(_,_) -> keep_errors;
+		| CMInfo(_,_) | CMWarning(_,_) -> predicate msg;)
+	) (List.rev ctx.messages))) in
+	com.get_messages <- (fun () -> (List.map (fun msg ->
+		(match msg with
+		| CMError(_,_) -> die "" __LOC__;
+		| CMInfo(_,_) | CMWarning(_,_) -> msg;)
+	) (filter_messages false (fun _ -> true))));
+	com.filter_messages <- (fun predicate -> (ctx.messages <- (List.rev (filter_messages true predicate))));
+	if CompilationServer.runs() then com.run_command <- run_command ctx;
+	com.class_path <- get_std_class_paths ();
+	com.std_path <- List.filter (fun p -> ExtString.String.ends_with p "std/" || ExtString.String.ends_with p "std\\") com.class_path
+
+let compile ctx actx =
+	let com = ctx.com in
+	(* Set up display configuration *)
+	process_display_configuration ctx;
+	let display_file_dot_path = DisplayOutput.process_display_file com actx in
+	(* Initialize target: This allows access to the appropriate std packages and sets the -D defines. *)
+	let ext = initialize_target ctx com actx in
+	(* if we are at the last compilation step, allow all packages accesses - in case of macros or opening another project file *)
+	if com.display.dms_display then begin match com.display.dms_kind with
+		| DMDefault | DMUsage _ -> ()
+		| _ -> if not ctx.has_next then com.package_rules <- PMap.foldi (fun p r acc -> match r with Forbidden -> acc | _ -> PMap.add p r acc) com.package_rules PMap.empty;
+	end;
+	com.config <- get_config com; (* make sure to adapt all flags changes defined after platform *)
+	let t = Timer.timer ["init"] in
+	List.iter (fun f -> f()) (List.rev (actx.pre_compilation));
+	t();
+	com.stage <- CInitialized;
+	if actx.classes = [([],"Std")] && not actx.force_typing then begin
+		if actx.cmds = [] && not actx.did_something then actx.raise_usage();
+	end else begin
+		(* Actual compilation starts here *)
+		let tctx = create_typer_context ctx actx.native_libs in
+		com.stage <- CTyperCreated;
+		let display_file_dot_path = match display_file_dot_path with
+			| DPKMacro path ->
+				ignore(load_display_module_in_macro tctx (Some path) true);
+				Some path
+			| DPKNormal path ->
+				Some path
+			| DPKNone ->
+				None
+			| DPKDirect file ->
+				DisplayOutput.load_display_file_standalone tctx file;
+				None
+			| DPKInput input ->
+				DisplayOutput.load_display_content_standalone tctx input;
+				None
+		in
+		begin try
+			do_type tctx actx
+		with TypeloadParse.DisplayInMacroBlock ->
+			ignore(load_display_module_in_macro tctx display_file_dot_path true);
+		end;
+		handle_display ctx tctx display_file_dot_path;
+		filter ctx tctx display_file_dot_path;
+		if ctx.has_error then raise Abort;
+		check_auxiliary_output com actx;
+		com.stage <- CGenerationStart;
+		if not actx.no_output then generate tctx ext actx;
+		com.stage <- CGenerationDone;
+	end;
+	Sys.catch_break false;
+	List.iter (fun f -> f()) (List.rev com.callbacks#get_after_generation);
+	if not actx.no_output then begin
+		List.iter (fun c ->
+			let r = run_command ctx c in
+			if r <> 0 then failwith ("Command failed with error " ^ string_of_int r)
+		) (List.rev actx.cmds)
+	end
+
+let finalize ctx =
+	List.iter (fun f ->
+		f();
+	) ctx.on_exit;
+	ctx.comm.flush ctx
+
+let compile_safe ctx f =
+	let com = ctx.com in
+try
+	f ()
+with
+	| Abort ->
+		()
+	| Error.Fatal_error (m,p) ->
+		error ctx m p
+	| Common.Abort (m,p) ->
+		error ctx m p
+	| Lexer.Error (m,p) ->
+		error ctx (Lexer.error_msg m) p
+	| Parser.Error (m,p) ->
+		error ctx (Parser.error_msg m) p
+	| Typecore.Forbid_package ((pack,m,p),pl,pf)  ->
+		if !Parser.display_mode <> DMNone && ctx.has_next then begin
+			ctx.has_error <- false;
+			ctx.messages <- [];
+		end else begin
+			error ctx (Printf.sprintf "You cannot access the %s package while %s (for %s)" pack (if pf = "macro" then "in a macro" else "targeting " ^ pf) (s_type_path m) ) p;
+			List.iter (error ctx (Error.compl_msg "referenced here")) (List.rev pl);
+		end
+	| Error.Error (m,p) ->
+		error ctx (Error.error_msg m) p
+	| Generic.Generic_Exception(m,p) ->
+		error ctx m p
+	| Arg.Bad msg ->
+		error ctx ("Error: " ^ msg) null_pos
+	| Failure msg when not Helper.is_debug_run ->
+		error ctx ("Error: " ^ msg) null_pos
+	| Helper.HelpMessage msg ->
+		com.info msg null_pos
+	| DisplayException(DisplayHover _ | DisplayPositions _ | DisplayFields _ | DisplayPackage _  | DisplaySignatures _ as de) when ctx.com.json_out <> None ->
+		begin
+			DisplayPosition.display_position#reset;
+			match ctx.com.json_out with
+			| Some api ->
+				let ctx = DisplayJson.create_json_context api.jsonrpc (match de with DisplayFields _ -> true | _ -> false) in
+				api.send_result (DisplayException.to_json ctx de)
+			| _ -> die "" __LOC__
+		end
+	(* | Parser.TypePath (_,_,_,p) when ctx.com.json_out <> None ->
+		begin match com.json_out with
+		| Some (f,_) ->
+			let tctx = Typer.create ctx.com in
+			let fields = DisplayToplevel.collect tctx true Typecore.NoValue in
+			let jctx = Genjson.create_context Genjson.GMMinimum in
+			f (DisplayException.fields_to_json jctx fields CRImport (Some (Parser.cut_pos_at_display p)) false)
+		| _ -> die "" __LOC__
+		end *)
+	| DisplayException(DisplayPackage pack) ->
+		DisplayPosition.display_position#reset;
+		raise (DisplayOutput.Completion (String.concat "." pack))
+	| DisplayException(DisplayFields Some r) ->
+		DisplayPosition.display_position#reset;
+		let fields = if !Timer.measure_times then begin
+			Timer.close_times();
+			(List.map (fun (name,value) ->
+				CompletionItem.make_ci_timer ("@TIME " ^ name) value
+			) (DisplayOutput.get_timer_fields !Helper.start_time)) @ r.fitems
+		end else
+			r.fitems
+		in
+		let s = match r.fkind with
+			| CRToplevel _
+			| CRTypeHint
+			| CRExtends
+			| CRImplements
+			| CRStructExtension _
+			| CRImport
+			| CRUsing
+			| CRNew
+			| CRPattern _
+			| CRTypeRelation
+			| CRTypeDecl ->
+				DisplayOutput.print_toplevel fields
+			| CRField _
+			| CRStructureField
+			| CRMetadata
+			| CROverride ->
+				DisplayOutput.print_fields fields
+		in
+		raise (DisplayOutput.Completion s)
+	| DisplayException(DisplayHover Some ({hitem = {CompletionItem.ci_type = Some (t,_)}} as hover)) ->
+		DisplayPosition.display_position#reset;
+		let doc = CompletionItem.get_documentation hover.hitem in
+		raise (DisplayOutput.Completion (DisplayOutput.print_type t hover.hpos doc))
+	| DisplayException(DisplaySignatures Some (signatures,_,display_arg,_)) ->
+		DisplayPosition.display_position#reset;
+		if ctx.com.display.dms_kind = DMSignature then
+			raise (DisplayOutput.Completion (DisplayOutput.print_signature signatures display_arg))
+		else
+			raise (DisplayOutput.Completion (DisplayOutput.print_signatures signatures))
+	| DisplayException(DisplayPositions pl) ->
+		DisplayPosition.display_position#reset;
+		raise (DisplayOutput.Completion (DisplayOutput.print_positions pl))
+	| Parser.TypePath (p,c,is_import,pos) ->
+		let fields =
+			try begin match c with
+				| None ->
+					DisplayPath.TypePathHandler.complete_type_path com p
+				| Some (c,cur_package) ->
+					let ctx = Typer.create com in
+					DisplayPath.TypePathHandler.complete_type_path_inner ctx p c cur_package is_import
+			end with Common.Abort(msg,p) ->
+				error ctx msg p;
+				None
+		in
+		begin match ctx.com.json_out,fields with
+		| None,None ->
+			()
+		| None,Some fields ->
+			raise (DisplayOutput.Completion (DisplayOutput.print_fields fields))
+		| Some api,None when is_legacy_completion com ->
+			api.send_result JNull
+		| Some api,fields ->
+			let fields = Option.default [] fields in
+			let ctx = DisplayJson.create_json_context api.jsonrpc false in
+			let path = match List.rev p with
+				| name :: pack -> List.rev pack,name
+				| [] -> [],""
+			in
+			let kind = CRField ((CompletionItem.make_ci_module path,pos,None,None)) in
+			api.send_result (DisplayException.fields_to_json ctx fields kind (DisplayTypes.make_subject None pos));
+		end
+	| Parser.SyntaxCompletion(kind,subj) ->
+		DisplayOutput.handle_syntax_completion com kind subj;
+		error ctx ("Error: No completion point was found") null_pos
+	| DisplayException(DisplayDiagnostics dctx) ->
+		let s = Json.string_of_json (DiagnosticsPrinter.json_of_diagnostics dctx) in
+		DisplayPosition.display_position#reset;
+		raise (DisplayOutput.Completion s)
+	| DisplayException(ModuleSymbols s | Statistics s | Metadata s) ->
+		DisplayPosition.display_position#reset;
+		raise (DisplayOutput.Completion s)
+	| EvalExceptions.Sys_exit i | Hlinterp.Sys_exit i ->
+		finalize ctx;
+		if !Timer.measure_times then Timer.report_times prerr_endline;
+		exit i
+	| DisplayOutput.Completion _ as exc ->
+		raise exc
+	| Out_of_memory as exc ->
+		raise exc
+	| e when (try Sys.getenv "OCAMLRUNPARAM" <> "b" || CompilationServer.runs() with _ -> true) && not Helper.is_debug_run ->
+		error ctx (Printexc.to_string e) null_pos
+
+let compile_ctx server_api comm ctx =
+	let run ctx =
+		setup_common_context ctx;
+		compile_safe ctx (fun () ->
+			let actx = Args.parse_args ctx.com in
+			begin match actx.server_mode with
+			| SMListen hp ->
+				let accept = match hp with
+				| "stdio" ->
+					server_api.init_wait_stdio()
+				| _ ->
+					let host, port = Helper.parse_host_port hp in
+					server_api.init_wait_socket host port
+				in
+				server_api.wait_loop ctx.com.verbose accept
+			| SMConnect hp ->
+				let host, port = Helper.parse_host_port hp in
+				let accept = server_api.init_wait_connect host port in
+				server_api.wait_loop ctx.com.verbose accept
+			| SMNone ->
+				()
+			end;
+			server_api.setup_new_context ctx.com;
+			compile ctx actx;
+		);
+		finalize ctx;
+	in
+	try
+		if ctx.has_error then begin
+			finalize ctx;
+			false (* can happen if process_params above fails already *)
+		end else begin
+			run ctx;
+			true (* reads as "continue?" *)
+		end
+	with
+		| DisplayOutput.Completion str ->
+			ServerMessage.completion str;
+			comm.write_err str;
+			false
+		| Arg.Bad msg ->
+			error ctx ("Error: " ^ msg) null_pos;
+			false
+
+let create_context comm params = {
+	com = Common.create version params;
+	on_exit = [];
+	messages = [];
+	has_next = false;
+	has_error = false;
+	comm = comm;
+}
+
+module HighLevel = struct
+	(* Returns a list of contexts, but doesn't do anything yet *)
+	let process_params server_api create pl =
+		let each_params = ref [] in
+		let compilations = DynArray.create () in
+		let curdir = Unix.getcwd () in
+		let add_context args =
+			let ctx = create args in
+			(* --cwd triggers immediately, so let's reset *)
+			Unix.chdir curdir;
+			DynArray.add compilations ctx;
+			ctx;
+		in
+		let rec loop acc = function
+			| [] ->
+				ignore(add_context (!each_params @ (List.rev acc)));
+			| "--next" :: l when acc = [] -> (* skip empty --next *)
+				loop [] l
+			| "--next" :: l ->
+				let ctx = add_context (!each_params @ (List.rev acc)) in
+				ctx.has_next <- true;
+				loop [] l
+			| "--each" :: l ->
+				each_params := List.rev acc;
+				loop [] l
+			| "--cwd" :: dir :: l | "-C" :: dir :: l ->
+				(* we need to change it immediately since it will affect hxml loading *)
+				(try Unix.chdir dir with _ -> raise (Arg.Bad ("Invalid directory: " ^ dir)));
+				(* Push the --cwd arg so the arg processor know we did something. *)
+				loop (dir :: "--cwd" :: acc) l
+			| "--connect" :: hp :: l ->
+				let host, port = (try ExtString.String.split hp ":" with _ -> "127.0.0.1", hp) in
+				server_api.do_connect host (try int_of_string port with _ -> raise (Arg.Bad "Invalid port")) ((List.rev acc) @ l)
+			| "--run" :: cl :: args ->
+				let acc = cl :: "-x" :: acc in
+				let ctx = add_context (!each_params @ (List.rev acc)) in
+				ctx.com.sys_args <- args;
+			| arg :: l ->
+				match List.rev (ExtString.String.nsplit arg ".") with
+				| "hxml" :: _ when (match acc with "-cmd" :: _ | "--cmd" :: _ -> false | _ -> true) ->
+					let acc, l = (try acc, Helper.parse_hxml arg @ l with Not_found -> (arg ^ " (file not found)") :: acc, l) in
+					loop acc l
+				| _ -> loop (arg :: acc) l
+		in
+		(* put --display in front if it was last parameter *)
+		let pl = (match List.rev pl with
+			| file :: "--display" :: pl when file <> "memory" -> "--display" :: file :: List.rev pl
+			| _ -> pl
+		) in
+		loop [] pl;
+		DynArray.to_list compilations
+
+	let entry server_api comm args =
+		let ctxs = try
+			process_params server_api (create_context comm) args
+		with Arg.Bad msg ->
+			let ctx = create_context comm args in
+			error ctx ("Error: " ^ msg) null_pos;
+			[ctx]
+		in
+		let success = List.fold_left (fun b ctx -> b && compile_ctx server_api comm ctx) true ctxs in
+		if success then begin
+			Timer.close_times();
+			if !Timer.measure_times then Timer.report_times (fun s -> comm.write_err (s ^ "\n"));
+		end;
+end

src/compiler/displayOutput.ml

@@ -2,6 +2,7 @@ open Globals
 open Ast
 open Common
 open Filename
+open CompilationContext
 open CompilationServer
 open Timer
 open DisplayTypes.DisplayMode
@@ -219,14 +220,14 @@ let unquote v =
 			| _ -> v
 	else v
 
-let handle_display_argument com file_pos pre_compilation did_something =
+let handle_display_argument com file_pos actx =
 	match file_pos with
 	| "classes" ->
-		pre_compilation := (fun() -> raise (Parser.TypePath (["."],None,true,null_pos))) :: !pre_compilation;
+		actx.pre_compilation <- (fun() -> raise (Parser.TypePath (["."],None,true,null_pos))) :: actx.pre_compilation;
 	| "keywords" ->
 		raise (Completion (print_keywords ()))
 	| "memory" ->
-		did_something := true;
+		actx.did_something <- true;
 		(try Memory.display_memory com with e -> prerr_endline (Printexc.get_backtrace ()));
 	| "diagnostics" ->
 		com.display <- DisplayMode.create (DMDiagnostics []);
@@ -288,7 +289,7 @@ type display_path_kind =
 	| DPKInput of string
 	| DPKNone
 
-let process_display_file com classes =
+let process_display_file com actx =
 	let get_module_path_from_file_path com spath =
 		let rec loop = function
 			| [] -> None
@@ -313,7 +314,7 @@ let process_display_file com classes =
 		| DFPNo ->
 			DPKNone
 		| DFPOnly when (DisplayPosition.display_position#get).pfile = file_input_marker ->
-			classes := [];
+			actx.classes <- [];
 			com.main_class <- None;
 			begin match !TypeloadParse.current_stdin with
 			| Some input ->
@@ -324,7 +325,7 @@ let process_display_file com classes =
 			end
 		| dfp ->
 			if dfp = DFPOnly then begin
-				classes := [];
+				actx.classes <- [];
 				com.main_class <- None;
 			end;
 			let real = Path.get_real_path (DisplayPosition.display_position#get).pfile in
@@ -337,11 +338,11 @@ let process_display_file com classes =
 						   This can happen if we're completing in such a file. *)
 						DPKMacro (fst path,name)
 					| [name] ->
-						classes := path :: !classes;
+						actx.classes <- path :: actx.classes;
 						DPKNormal path
 					| [name;target] ->
 						let path = fst path, name in
-						classes := path :: !classes;
+						actx.classes <- path :: actx.classes;
 						DPKNormal path
 					| e ->
 						die "" __LOC__
@@ -355,7 +356,7 @@ let process_display_file com classes =
 				DPKDirect real
 			in
 			Common.log com ("Display file : " ^ real);
-			Common.log com ("Classes found : ["  ^ (String.concat "," (List.map s_type_path !classes)) ^ "]");
+			Common.log com ("Classes found : ["  ^ (String.concat "," (List.map s_type_path actx.classes)) ^ "]");
 			path
 
 let load_display_file_standalone ctx file =
@@ -475,7 +476,7 @@ let handle_syntax_completion com kind subj =
 		()
 	| _ ->
 		let l = List.map make_ci_keyword l in
-		match com.json_out with
+		match com.Common.json_out with
 		| None ->
 			let b = Buffer.create 0 in
 			Buffer.add_string b "<il>\n";

src/compiler/helper.ml

@@ -0,0 +1,49 @@
+exception HelpMessage of string
+
+let is_debug_run = try Sys.getenv "HAXEDEBUG" = "1" with _ -> false
+
+let start_time = ref (Timer.get_time())
+
+let prompt = ref false
+
+let expand_env ?(h=None) path  =
+	let r = Str.regexp "%\\([A-Za-z0-9_]+\\)%" in
+	Str.global_substitute r (fun s ->
+		let key = Str.matched_group 1 s in
+		try
+			Sys.getenv key
+		with Not_found -> try
+			match h with
+			| None -> raise Not_found
+			| Some h -> Hashtbl.find h key
+		with Not_found ->
+			"%" ^ key ^ "%"
+	) path
+
+let parse_hxml_data data =
+	let open DisplayOutput in
+	let lines = Str.split (Str.regexp "[\r\n]+") data in
+	List.concat (List.map (fun l ->
+		let l = unquote (ExtString.String.strip l) in
+		if l = "" || l.[0] = '#' then
+			[]
+		else if l.[0] = '-' then
+			try
+				let a, b = ExtString.String.split l " " in
+				[unquote a; unquote (ExtString.String.strip b)]
+			with
+				_ -> [l]
+		else
+			[l]
+	) lines)
+
+let parse_hxml file =
+	let ch = IO.input_channel (try open_in_bin file with _ -> raise Not_found) in
+	let data = IO.read_all ch in
+	IO.close_in ch;
+	parse_hxml_data data
+
+let parse_host_port hp =
+	let host, port = (try ExtString.String.split hp ":" with _ -> "127.0.0.1", hp) in
+	let port = try int_of_string port with _ -> raise (Arg.Bad "Invalid port") in
+	host, port

src/compiler/server.ml

@@ -3,29 +3,16 @@ open Globals
 open Ast
 open Common
 open CompilationServer
-open DisplayTypes.DisplayMode
 open Timer
 open Type
 open DisplayOutput
 open Json
+open Compiler
+open CompilationContext
 
 exception Dirty of path
 exception ServerError of string
 
-let prompt = ref false
-let start_time = ref (Timer.get_time())
-
-let is_debug_run = try Sys.getenv "HAXEDEBUG" = "1" with _ -> false
-
-type context = {
-	com : Common.context;
-	mutable flush : unit -> unit;
-	mutable setup : unit -> unit;
-	mutable messages : compiler_message list;
-	mutable has_next : bool;
-	mutable has_error : bool;
-}
-
 let check_display_flush ctx f_otherwise = match ctx.com.json_out with
 	| None ->
 		begin match ctx.com.display.dms_kind with
@@ -59,64 +46,6 @@ let check_display_flush ctx f_otherwise = match ctx.com.json_out with
 			api.send_error errors
 		end
 
-let default_flush ctx =
-	check_display_flush ctx (fun () ->
-		List.iter
-			(fun msg -> match msg with
-				| CMInfo _ -> print_endline (compiler_message_string msg)
-				| CMWarning _ | CMError _ -> prerr_endline (compiler_message_string msg)
-			)
-			(List.rev ctx.messages);
-		if ctx.has_error && !prompt then begin
-			print_endline "Press enter to exit...";
-			ignore(read_line());
-		end;
-		if ctx.has_error then exit 1
-	)
-
-let create_context params =
-	let ctx = {
-		com = Common.create version params;
-		flush = (fun()->());
-		setup = (fun()->());
-		messages = [];
-		has_next = false;
-		has_error = false;
-	} in
-	ctx.flush <- (fun() -> default_flush ctx);
-	ctx
-
-let parse_hxml_data data =
-	let lines = Str.split (Str.regexp "[\r\n]+") data in
-	List.concat (List.map (fun l ->
-		let l = unquote (ExtString.String.strip l) in
-		if l = "" || l.[0] = '#' then
-			[]
-		else if l.[0] = '-' then
-			try
-				let a, b = ExtString.String.split l " " in
-				[unquote a; unquote (ExtString.String.strip b)]
-			with
-				_ -> [l]
-		else
-			[l]
-	) lines)
-
-let parse_hxml file =
-	let ch = IO.input_channel (try open_in_bin file with _ -> raise Not_found) in
-	let data = IO.read_all ch in
-	IO.close_in ch;
-	parse_hxml_data data
-
-let ssend sock str =
-	let rec loop pos len =
-		if len = 0 then
-			()
-		else
-			let s = Unix.send sock str pos len [] in
-			loop (pos + s) (len - s)
-	in
-	loop 0 (Bytes.length str)
 
 let current_stdin = ref None
 
@@ -206,13 +135,91 @@ module ServerCompilationContext = struct
 		sctx.delays <- [];
 		List.iter (fun f -> f()) fl
 
+	(* Resets the state for a new compilation *)
 	let reset sctx =
 		Hashtbl.clear sctx.changed_directories;
-		sctx.was_compilation <- false
+		sctx.was_compilation <- false;
+		Parser.reset_state();
+		return_partial_type := false;
+		measure_times := false;
+		Hashtbl.clear DeprecationCheck.warned_positions;
+		close_times();
+		stats.s_files_parsed := 0;
+		stats.s_classes_built := 0;
+		stats.s_methods_typed := 0;
+		stats.s_macros_called := 0;
+		Hashtbl.clear Timer.htimers;
+		sctx.compilation_step <- sctx.compilation_step + 1;
+		sctx.compilation_mark <- sctx.mark_loop;
+		Helper.start_time := get_time()
+
+	let maybe_cache_context sctx com =
+		if com.display.dms_full_typing then begin
+			CommonCache.cache_context sctx.cs com;
+			ServerMessage.cached_modules com "" (List.length com.modules);
+		end
+
+	let cleanup () = match !MacroContext.macro_interp_cache with
+		| Some interp -> EvalContext.GlobalState.cleanup interp
+		| None -> ()
 end
 
 open ServerCompilationContext
 
+module Communication = struct
+	let create_stdio () = {
+		write_out = (fun s ->
+			print_string s;
+			flush stdout;
+		);
+		write_err = (fun s ->
+			prerr_string s;
+		);
+		flush = (fun ctx ->
+			List.iter (fun msg -> match msg with
+				| CMInfo _ -> print_endline (compiler_message_string msg)
+				| CMWarning _ | CMError _ -> prerr_endline (compiler_message_string msg)
+			) (List.rev ctx.messages);
+			if ctx.has_error && !Helper.prompt then begin
+				print_endline "Press enter to exit...";
+				ignore(read_line());
+			end;
+			flush stdout;
+			if ctx.has_error then exit 1
+		);
+		is_server = false;
+	}
+
+	let create_pipe sctx write = {
+		write_out = (fun s ->
+			write ("\x01" ^ String.concat "\x01" (ExtString.String.nsplit s "\n") ^ "\n")
+		);
+		write_err = (fun s ->
+			write s
+		);
+		flush = (fun ctx ->
+			sctx.compilation_step <- sctx.compilation_step + 1;
+			sctx.compilation_mark <- sctx.mark_loop;
+			check_display_flush ctx (fun () ->
+				List.iter
+					(fun msg ->
+						let s = compiler_message_string msg in
+						write (s ^ "\n");
+						ServerMessage.message s;
+					)
+					(List.rev ctx.messages);
+				sctx.was_compilation <- ctx.com.display.dms_full_typing;
+				if ctx.has_error then begin
+					measure_times := false;
+					write "\x02\n"
+				end else
+					maybe_cache_context sctx ctx.com;
+			)
+		);
+		is_server = false;
+	}
+end
+
 let stat dir =
 	(Unix.stat (Path.remove_trailing_slash dir)).Unix.st_mtime
 
@@ -465,152 +472,164 @@ let type_module sctx (ctx:Typecore.typer) mpath p =
 		t();
 		None
 
-(* Sets up the per-compilation context. *)
-let create sctx write params =
+let setup_new_context sctx com =
 	let cs = sctx.cs in
-	let maybe_cache_context com =
-		if com.display.dms_full_typing then begin
-			CommonCache.cache_context sctx.cs com;
-			ServerMessage.cached_modules com "" (List.length com.modules);
+	let sign = Define.get_signature com.defines in
+	ServerMessage.defines com "";
+	ServerMessage.signature com "" sign;
+	ServerMessage.display_position com "" (DisplayPosition.display_position#get);
+	try
+		if (Hashtbl.find sctx.class_paths sign) <> com.class_path then begin
+			ServerMessage.class_paths_changed com "";
+			Hashtbl.replace sctx.class_paths sign com.class_path;
+			cs#clear_directories sign;
+			(cs#get_context sign)#set_initialized false;
+		end;
+	with Not_found ->
+		Hashtbl.add sctx.class_paths sign com.class_path;
+		()
+
+let mk_length_prefixed_communication allow_nonblock chin chout =
+	let sin = Unix.descr_of_in_channel chin in
+	let chin = IO.input_channel chin in
+	let chout = IO.output_channel chout in
+
+	let bout = Buffer.create 0 in
+
+	let block () = Unix.clear_nonblock sin in
+	let unblock () = Unix.set_nonblock sin in
+
+	let read_nonblock _ =
+        let len = IO.read_i32 chin in
+        Some (IO.really_nread_string chin len)
+	in
+	let read = if allow_nonblock then fun do_block ->
+		if do_block then begin
+			block();
+			read_nonblock true;
+		end else begin
+			let c0 =
+				unblock();
+				try
+					Some (IO.read_byte chin)
+				with
+				| Sys_blocked_io
+				(* TODO: We're supposed to catch Sys_blocked_io only, but that doesn't work on my PC... *)
+				| Sys_error _ ->
+					None
+			in
+			begin match c0 with
+			| Some c0 ->
+				block(); (* We got something, make sure we block until we're done. *)
+				let c1 = IO.read_byte chin in
+				let c2 = IO.read_byte chin in
+				let c3 = IO.read_byte chin in
+				let len = c3 lsl 24 + c2 lsl 16 + c1 lsl 8 + c0 in
+				Some (IO.really_nread_string chin len)
+			| None ->
+				None
+			end
 		end
+	else read_nonblock in
+
+	let write = Buffer.add_string bout in
+
+	let close = fun() ->
+		IO.write_i32 chout (Buffer.length bout);
+		IO.nwrite_string chout (Buffer.contents bout);
+		IO.flush chout
 	in
-	let ctx = create_context params in
-	ctx.flush <- (fun() ->
-		sctx.compilation_step <- sctx.compilation_step + 1;
-		sctx.compilation_mark <- sctx.mark_loop;
-		check_display_flush ctx (fun () ->
-			List.iter
-				(fun msg ->
-					let s = compiler_message_string msg in
-					write (s ^ "\n");
-					ServerMessage.message s;
-				)
-				(List.rev ctx.messages);
-			sctx.was_compilation <- ctx.com.display.dms_full_typing;
-			if ctx.has_error then begin
-				measure_times := false;
-				write "\x02\n"
-			end else maybe_cache_context ctx.com;
-		)
-	);
-	ctx.setup <- (fun() ->
-		let sign = Define.get_signature ctx.com.defines in
-		ServerMessage.defines ctx.com "";
-		ServerMessage.signature ctx.com "" sign;
-		ServerMessage.display_position ctx.com "" (DisplayPosition.display_position#get);
-		try
-			if (Hashtbl.find sctx.class_paths sign) <> ctx.com.class_path then begin
-				ServerMessage.class_paths_changed ctx.com "";
-				Hashtbl.replace sctx.class_paths sign ctx.com.class_path;
-				cs#clear_directories sign;
-				(cs#get_context sign)#set_initialized false;
-			end;
-		with Not_found ->
-			Hashtbl.add sctx.class_paths sign ctx.com.class_path;
+
+	fun () ->
+		Buffer.clear bout;
+		allow_nonblock, read, write, close
+
+let ssend sock str =
+	let rec loop pos len =
+		if len = 0 then
 			()
-	);
-	ctx.com.print <- (fun str -> write ("\x01" ^ String.concat "\x01" (ExtString.String.nsplit str "\n") ^ "\n"));
-	ctx
-
-(* Resets the state for a new compilation *)
-let init_new_compilation sctx =
-	ServerCompilationContext.reset sctx;
-	Parser.reset_state();
-	return_partial_type := false;
-	measure_times := false;
-	Hashtbl.clear DeprecationCheck.warned_positions;
-	close_times();
-	stats.s_files_parsed := 0;
-	stats.s_classes_built := 0;
-	stats.s_methods_typed := 0;
-	stats.s_macros_called := 0;
-	Hashtbl.clear Timer.htimers;
-	sctx.compilation_step <- sctx.compilation_step + 1;
-	sctx.compilation_mark <- sctx.mark_loop;
-	start_time := get_time()
-
-let cleanup () =
-	begin match !MacroContext.macro_interp_cache with
-	| Some interp -> EvalContext.GlobalState.cleanup interp
-	| None -> ()
-	end
-
-let gc_heap_stats () =
-	let stats = Gc.quick_stat() in
-	stats.major_words,stats.heap_words
-
-let fmt_percent f =
-	int_of_float (f *. 100.)
-
-module Tasks = struct
-	class gc_task (max_working_memory : float) (heap_size : float) = object(self)
-		inherit server_task ["gc"] 100
-
-		method private execute =
-			let t0 = get_time() in
-			let stats = Gc.stat() in
-			let live_words = float_of_int stats.live_words in
-			(* Maximum heap size needed for the last X compilations = sum of what's live + max working memory. *)
-			let needed_max = live_words +. max_working_memory in
-			(* Additional heap percentage needed = what's live / max of what was live. *)
-			let percent_needed = (1. -. live_words /. needed_max) in
-			(* Effective cache size percentage = what's live / heap size. *)
-			let percent_used = live_words /. heap_size in
-			(* Set allowed space_overhead to the maximum of what we needed during the last X compilations. *)
-			let new_space_overhead = int_of_float ((percent_needed +. 0.05) *. 100.) in
-			let old_gc = Gc.get() in
-			Gc.set { old_gc with Gc.space_overhead = new_space_overhead; };
-			(* Compact if less than 80% of our heap words consist of the cache and there's less than 50% overhead. *)
-			let do_compact = percent_used < 0.8 && percent_needed < 0.5 in
-			begin if do_compact then
-				Gc.compact()
-			else
-				Gc.full_major();
+		else
+			let s = Unix.send sock str pos len [] in
+			loop (pos + s) (len - s)
+	in
+	loop 0 (Bytes.length str)
+
+(* The accept-function to wait for a stdio connection. *)
+let init_wait_stdio() =
+	set_binary_mode_in stdin true;
+	set_binary_mode_out stderr true;
+	mk_length_prefixed_communication false stdin stderr
+
+(* The connect function to connect to [host] at [port] and send arguments [args]. *)
+let do_connect host port args =
+	let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+	(try Unix.connect sock (Unix.ADDR_INET (Unix.inet_addr_of_string host,port)) with _ -> failwith ("Couldn't connect on " ^ host ^ ":" ^ string_of_int port));
+	let rec display_stdin args =
+		match args with
+		| [] -> ""
+		| "-D" :: ("display_stdin" | "display-stdin") :: _ ->
+			let accept = init_wait_stdio() in
+			let _, read, _, _ = accept() in
+			Option.default "" (read true)
+		| _ :: args ->
+			display_stdin args
+	in
+	let args = ("--cwd " ^ Unix.getcwd()) :: args in
+	let s = (String.concat "" (List.map (fun a -> a ^ "\n") args)) ^ (display_stdin args) in
+	ssend sock (Bytes.of_string (s ^ "\000"));
+	let has_error = ref false in
+	let rec print line =
+		match (if line = "" then '\x00' else line.[0]) with
+		| '\x01' ->
+			print_string (String.concat "\n" (List.tl (ExtString.String.nsplit line "\x01")));
+			flush stdout
+		| '\x02' ->
+			has_error := true;
+		| _ ->
+			prerr_endline line;
+	in
+	let buf = Buffer.create 0 in
+	let process() =
+		let lines = ExtString.String.nsplit (Buffer.contents buf) "\n" in
+		(* the last line ends with \n *)
+		let lines = (match List.rev lines with "" :: l -> List.rev l | _ -> lines) in
+		List.iter print lines;
+	in
+	let tmp = Bytes.create 1024 in
+	let rec loop() =
+		let b = Unix.recv sock tmp 0 1024 [] in
+		Buffer.add_subbytes buf tmp 0 b;
+		if b > 0 then begin
+			if Bytes.get tmp (b - 1) = '\n' then begin
+				process();
+				Buffer.reset buf;
 			end;
-			Gc.set old_gc;
-			ServerMessage.gc_stats (get_time() -. t0) stats do_compact new_space_overhead
-	end
-
-	class class_maintenance_task (cs : CompilationServer.t) (c : tclass) = object(self)
-		inherit server_task ["module maintenance"] 70
-
-		method private execute =
-			let rec field cf =
-				(* Unset cf_expr. This holds the optimized version for generators, which we don't need to persist. If
-				   we compile again, the semi-optimized expression will be restored by calling cl_restore(). *)
-				cf.cf_expr <- None;
-				List.iter field cf.cf_overloads
-			in
-			(* What we're doing here at the moment is free, so we can just do it in one task. If this ever gets more expensive,
-			   we should spawn a task per-field. *)
-			List.iter field c.cl_ordered_fields;
-			List.iter field c.cl_ordered_statics;
-			Option.may field c.cl_constructor;
-	end
-
-	class module_maintenance_task (cs : CompilationServer.t) (m : module_def) = object(self)
-		inherit server_task ["module maintenance"] 80
-
-		method private execute =
-			List.iter (fun mt -> match mt with
-				| TClassDecl c ->
-					cs#add_task (new class_maintenance_task cs c)
-				| _ ->
-					()
-			) m.m_types
-	end
-
-	class server_exploration_task (cs : CompilationServer.t) = object(self)
-		inherit server_task ["server explore"] 90
-
-		method private execute =
-			cs#iter_modules (fun m -> cs#add_task (new module_maintenance_task cs m))
-	end
-end
+			loop();
+		end
+	in
+	loop();
+	process();
+	if !has_error then exit 1
+
+let rec process sctx comm args =
+	let t0 = get_time() in
+	ServerMessage.arguments args;
+	reset sctx;
+	let api = {
+		setup_new_context = setup_new_context sctx;
+		init_wait_socket = init_wait_socket;
+		init_wait_connect = init_wait_connect;
+		init_wait_stdio = init_wait_stdio;
+		wait_loop = wait_loop;
+		do_connect = do_connect;
+	} in
+	Compiler.HighLevel.entry api comm args;
+	run_delays sctx;
+	ServerMessage.stats stats (get_time() -. t0)
 
 (* The server main loop. Waits for the [accept] call to then process the sent compilation
    parameters through [process_params]. *)
-let wait_loop process_params verbose accept =
+and wait_loop verbose accept =
 	if verbose then ServerMessage.enable_all ();
 	Sys.catch_break false; (* Sys can never catch a break *)
 	(* Create server context and set up hooks for parsing and typing *)
@@ -620,6 +639,10 @@ let wait_loop process_params verbose accept =
 	MacroContext.macro_enable_cache := true;
 	TypeloadParse.parse_hook := parse_file cs;
 	let ring = Ring.create 10 0. in
+	let gc_heap_stats () =
+		let stats = Gc.quick_stat() in
+		stats.major_words,stats.heap_words
+	in
 	let heap_stats_start = ref (gc_heap_stats()) in
 	let update_heap () =
 		(* On every compilation: Track how many words were allocated for this compilation (working memory). *)
@@ -638,41 +661,21 @@ let wait_loop process_params verbose accept =
 	(* Main loop: accept connections and process arguments *)
 	while true do
 		let support_nonblock, read, write, close = accept() in
-		let process s =
-			let t0 = get_time() in
-			let hxml =
-				try
-					let idx = String.index s '\001' in
-					current_stdin := Some (String.sub s (idx + 1) ((String.length s) - idx - 1));
-					(String.sub s 0 idx)
-				with Not_found ->
-					s
-			in
-			let data = parse_hxml_data hxml in
-			ServerMessage.arguments data;
-			init_new_compilation sctx;
-			begin try
-				let create = create sctx write in
-				(* Pass arguments to normal handling in main.ml *)
-				process_params create data;
-				close_times();
-				if !measure_times then report_times (fun s -> write (s ^ "\n"))
-			with
-			| Completion str ->
-				ServerMessage.completion str;
-				write str
-			| Arg.Bad msg ->
-				print_endline ("Error: " ^ msg);
-			end;
-			run_delays sctx;
-			ServerMessage.stats stats (get_time() -. t0)
-		in
 		begin try
 			(* Read arguments *)
 			let rec loop block =
 				match read block with
-				| Some data ->
-					process data
+				| Some s ->
+					let hxml =
+						try
+							let idx = String.index s '\001' in
+							current_stdin := Some (String.sub s (idx + 1) ((String.length s) - idx - 1));
+							(String.sub s 0 idx)
+						with Not_found ->
+							s
+					in
+					let data = Helper.parse_hxml_data hxml in
+					process sctx (Communication.create_pipe sctx write) data
 				| None ->
 					if not cs#has_task then
 						(* If there is no pending task, turn into blocking mode. *)
@@ -690,7 +693,7 @@ let wait_loop process_params verbose accept =
 			let estr = Printexc.to_string e in
 			ServerMessage.uncaught_error estr;
 			(try write ("\x02\n" ^ estr); with _ -> ());
-			if is_debug_run then print_endline (estr ^ "\n" ^ Printexc.get_backtrace());
+			if Helper.is_debug_run then print_endline (estr ^ "\n" ^ Printexc.get_backtrace());
 			if e = Out_of_memory then begin
 				close();
 				exit (-1);
@@ -708,75 +711,14 @@ let wait_loop process_params verbose accept =
 			cs#add_task (new Tasks.server_exploration_task cs)
 	done
 
-let mk_length_prefixed_communication allow_nonblock chin chout =
-	let sin = Unix.descr_of_in_channel chin in
-	let chin = IO.input_channel chin in
-	let chout = IO.output_channel chout in
-
-	let bout = Buffer.create 0 in
-
-	let block () = Unix.clear_nonblock sin in
-	let unblock () = Unix.set_nonblock sin in
-
-	let read_nonblock _ =
-        let len = IO.read_i32 chin in
-        Some (IO.really_nread_string chin len)
-	in
-	let read = if allow_nonblock then fun do_block ->
-		if do_block then begin
-			block();
-			read_nonblock true;
-		end else begin
-			let c0 =
-				unblock();
-				try
-					Some (IO.read_byte chin)
-				with
-				| Sys_blocked_io
-				(* TODO: We're supposed to catch Sys_blocked_io only, but that doesn't work on my PC... *)
-				| Sys_error _ ->
-					None
-			in
-			begin match c0 with
-			| Some c0 ->
-				block(); (* We got something, make sure we block until we're done. *)
-				let c1 = IO.read_byte chin in
-				let c2 = IO.read_byte chin in
-				let c3 = IO.read_byte chin in
-				let len = c3 lsl 24 + c2 lsl 16 + c1 lsl 8 + c0 in
-				Some (IO.really_nread_string chin len)
-			| None ->
-				None
-			end
-		end
-	else read_nonblock in
-
-	let write = Buffer.add_string bout in
-
-	let close = fun() ->
-		IO.write_i32 chout (Buffer.length bout);
-		IO.nwrite_string chout (Buffer.contents bout);
-		IO.flush chout
-	in
-
-	fun () ->
-		Buffer.clear bout;
-		allow_nonblock, read, write, close
-
-(* The accept-function to wait for a stdio connection. *)
-let init_wait_stdio() =
-	set_binary_mode_in stdin true;
-	set_binary_mode_out stderr true;
-	mk_length_prefixed_communication false stdin stderr
-
 (* Connect to given host/port and return accept function for communication *)
-let init_wait_connect host port =
+and init_wait_connect host port =
 	let host = Unix.inet_addr_of_string host in
 	let chin, chout = Unix.open_connection (Unix.ADDR_INET (host,port)) in
 	mk_length_prefixed_communication true chin chout
 
 (* The accept-function to wait for a socket connection. *)
-let init_wait_socket host port =
+and init_wait_socket host port =
 	let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
 	(try Unix.setsockopt sock Unix.SO_REUSEADDR true with _ -> ());
 	(try Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_of_string host,port)) with _ -> failwith ("Couldn't wait on " ^ host ^ ":" ^ string_of_int port));
@@ -816,55 +758,4 @@ let init_wait_socket host port =
 		let close() = Unix.close sin in
 		false, read, write, close
 	) in
-	accept
-
-(* The connect function to connect to [host] at [port] and send arguments [args]. *)
-let do_connect host port args =
-	let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
-	(try Unix.connect sock (Unix.ADDR_INET (Unix.inet_addr_of_string host,port)) with _ -> failwith ("Couldn't connect on " ^ host ^ ":" ^ string_of_int port));
-	let rec display_stdin args =
-		match args with
-		| [] -> ""
-		| "-D" :: ("display_stdin" | "display-stdin") :: _ ->
-			let accept = init_wait_stdio() in
-			let _, read, _, _ = accept() in
-			Option.default "" (read true)
-		| _ :: args ->
-			display_stdin args
-	in
-	let args = ("--cwd " ^ Unix.getcwd()) :: args in
-	let s = (String.concat "" (List.map (fun a -> a ^ "\n") args)) ^ (display_stdin args) in
-	ssend sock (Bytes.of_string (s ^ "\000"));
-	let has_error = ref false in
-	let rec print line =
-		match (if line = "" then '\x00' else line.[0]) with
-		| '\x01' ->
-			print_string (String.concat "\n" (List.tl (ExtString.String.nsplit line "\x01")));
-			flush stdout
-		| '\x02' ->
-			has_error := true;
-		| _ ->
-			prerr_endline line;
-	in
-	let buf = Buffer.create 0 in
-	let process() =
-		let lines = ExtString.String.nsplit (Buffer.contents buf) "\n" in
-		(* the last line ends with \n *)
-		let lines = (match List.rev lines with "" :: l -> List.rev l | _ -> lines) in
-		List.iter print lines;
-	in
-	let tmp = Bytes.create 1024 in
-	let rec loop() =
-		let b = Unix.recv sock tmp 0 1024 [] in
-		Buffer.add_subbytes buf tmp 0 b;
-		if b > 0 then begin
-			if Bytes.get tmp (b - 1) = '\n' then begin
-				process();
-				Buffer.reset buf;
-			end;
-			loop();
-		end
-	in
-	loop();
-	process();
-	if !has_error then exit 1
+	accept

src/compiler/tasks.ml

@@ -0,0 +1,67 @@
+
+open Type
+open CompilationServer
+
+class gc_task (max_working_memory : float) (heap_size : float) = object(self)
+	inherit server_task ["gc"] 100
+
+	method private execute =
+		let t0 = Timer.get_time() in
+		let stats = Gc.stat() in
+		let live_words = float_of_int stats.live_words in
+		(* Maximum heap size needed for the last X compilations = sum of what's live + max working memory. *)
+		let needed_max = live_words +. max_working_memory in
+		(* Additional heap percentage needed = what's live / max of what was live. *)
+		let percent_needed = (1. -. live_words /. needed_max) in
+		(* Effective cache size percentage = what's live / heap size. *)
+		let percent_used = live_words /. heap_size in
+		(* Set allowed space_overhead to the maximum of what we needed during the last X compilations. *)
+		let new_space_overhead = int_of_float ((percent_needed +. 0.05) *. 100.) in
+		let old_gc = Gc.get() in
+		Gc.set { old_gc with Gc.space_overhead = new_space_overhead; };
+		(* Compact if less than 80% of our heap words consist of the cache and there's less than 50% overhead. *)
+		let do_compact = percent_used < 0.8 && percent_needed < 0.5 in
+		begin if do_compact then
+			Gc.compact()
+		else
+			Gc.full_major();
+		end;
+		Gc.set old_gc;
+		ServerMessage.gc_stats (Timer.get_time() -. t0) stats do_compact new_space_overhead
+end
+
+class class_maintenance_task (cs : CompilationServer.t) (c : tclass) = object(self)
+	inherit server_task ["module maintenance"] 70
+
+	method private execute =
+		let rec field cf =
+			(* Unset cf_expr. This holds the optimized version for generators, which we don't need to persist. If
+				we compile again, the semi-optimized expression will be restored by calling cl_restore(). *)
+			cf.cf_expr <- None;
+			List.iter field cf.cf_overloads
+		in
+		(* What we're doing here at the moment is free, so we can just do it in one task. If this ever gets more expensive,
+			we should spawn a task per-field. *)
+		List.iter field c.cl_ordered_fields;
+		List.iter field c.cl_ordered_statics;
+		Option.may field c.cl_constructor;
+end
+
+class module_maintenance_task (cs : CompilationServer.t) (m : module_def) = object(self)
+	inherit server_task ["module maintenance"] 80
+
+	method private execute =
+		List.iter (fun mt -> match mt with
+			| TClassDecl c ->
+				cs#add_task (new class_maintenance_task cs c)
+			| _ ->
+				()
+		) m.m_types
+end
+
+class server_exploration_task (cs : CompilationServer.t) = object(self)
+	inherit server_task ["server explore"] 90
+
+	method private execute =
+		cs#iter_modules (fun m -> cs#add_task (new module_maintenance_task cs m))
+end

src/context/common.ml

@@ -862,6 +862,15 @@ let init_platform com pf =
 	raw_define_value com.defines "target.name" name;
 	raw_define com name
 
+let set_platform com pf file =
+	if com.platform <> Cross then failwith "Multiple targets";
+	init_platform com pf;
+	com.file <- file;
+	if (pf = Flash) && file_extension file = "swc" then define com Define.Swc;
+	(* Set the source header, unless the user has set one already or the platform sets a custom one *)
+	if not (defined com Define.SourceHeader) && (pf <> Hl) then
+		define_value com Define.SourceHeader ("Generated by Haxe " ^ s_version_full)
+
 let add_feature com f =
 	Hashtbl.replace com.features f true
 

tests/RunCi.hx

@@ -46,7 +46,7 @@ class RunCi {
 			infoMsg('test $test');
 			try {
 				changeDirectory(unitDir);
-				haxelibInstallGit("haxe-utest", "utest", "master");
+				haxelibInstallGit("haxe-utest", "utest", "master", "--always");
 
 				var args = switch (ci) {
 					case null: