[server] turn server.ml into something readable

src/compiler/server.ml

@@ -129,51 +129,187 @@ let ssend sock str =
 	in
 	loop 0 (Bytes.length str)
 
-let rec wait_loop process_params verbose accept =
-	if verbose then ServerMessage.enable_all ();
-	Sys.catch_break false; (* Sys can never catch a break *)
-	let cs = CompilationServer.create () in
-	MacroContext.macro_enable_cache := true;
-	let current_stdin = ref None in
-	TypeloadParse.parse_hook := (fun com2 file p ->
-		let ffile = Path.unique_full_path file in
-		let is_display_file = ffile = (DisplayPosition.display_position#get).pfile in
+let current_stdin = ref None
 
-		match is_display_file, !current_stdin with
-		| true, Some stdin when Common.defined com2 Define.DisplayStdin ->
-			TypeloadParse.parse_file_from_string com2 file p stdin
-		| _ ->
-			let sign = Define.get_signature com2.defines in
-			let ftime = file_time ffile in
-			let fkey = (ffile,sign) in
-			let data = Std.finally (Timer.timer ["server";"parser cache"]) (fun () ->
+let parse_file cs com file p =
+	let ffile = Path.unique_full_path file in
+	let is_display_file = ffile = (DisplayPosition.display_position#get).pfile in
+	match is_display_file, !current_stdin with
+	| true, Some stdin when Common.defined com Define.DisplayStdin ->
+		TypeloadParse.parse_file_from_string com file p stdin
+	| _ ->
+		let sign = Define.get_signature com.defines in
+		let ftime = file_time ffile in
+		let fkey = (ffile,sign) in
+		let data = Std.finally (Timer.timer ["server";"parser cache"]) (fun () ->
+			try
+				let cfile = CompilationServer.find_file cs fkey in
+				if cfile.c_time <> ftime then raise Not_found;
+				Parser.ParseSuccess(cfile.c_package,cfile.c_decls)
+			with Not_found ->
+				let parse_result = TypeloadParse.parse_file com file p in
+				let info,is_unusual = match parse_result with
+					| ParseError(_,_,_) -> "not cached, has parse error",true
+					| ParseDisplayFile _ -> "not cached, is display file",true
+					| ParseSuccess data ->
+						begin try
+							(* We assume that when not in display mode it's okay to cache stuff that has #if display
+							checks. The reasoning is that non-display mode has more information than display mode. *)
+							if not com.display.dms_display then raise Not_found;
+							let ident = Hashtbl.find Parser.special_identifier_files ffile in
+							Printf.sprintf "not cached, using \"%s\" define" ident,true
+						with Not_found ->
+							CompilationServer.cache_file cs fkey ftime data;
+							"cached",false
+						end
+				in
+				if is_unusual then ServerMessage.parsed com "" (ffile,info);
+				parse_result
+		) () in
+		data
+
+module ServerCompilationContext = struct
+	type t = {
+		(* If true, prints some debug information *)
+		verbose : bool;
+		(* The list of changed directories per-signature *)
+		changed_directories : (Digest.t,cached_directory list) Hashtbl.t;
+		(* A reference to the compilation server instance *)
+		cs : CompilationServer.t;
+		(* A list of class paths per-signature *)
+		class_paths : (Digest.t,string list) Hashtbl.t;
+		(* Increased for each typed module *)
+		mutable mark_loop : int;
+		(* Increased for each compilation *)
+		mutable compilation_step : int;
+		(* The [mark_loop] value at which we started the current compilation *)
+		mutable compilation_mark : int;
+		(* A list of delays which are run after compilation *)
+		mutable delays : (unit -> unit) list;
+		(* A list of modules which were (perhaps temporarily) removed from the cache *)
+		mutable removed_modules : ((path * string) * module_def) list;
+		(* True if it's an actual compilation, false if it's a display operation *)
+		mutable was_compilation : bool;
+	}
+
+	let create verbose cs = {
+		verbose = verbose;
+		cs = cs;
+		class_paths = Hashtbl.create 0;
+		changed_directories = Hashtbl.create 0;
+		compilation_step = 0;
+		compilation_mark = 0;
+		mark_loop = 0;
+		delays = [];
+		removed_modules = [];
+		was_compilation = false;
+	}
+
+	let add_delay sctx f =
+		sctx.delays <- f :: sctx.delays
+
+	let run_delays sctx =
+		let fl = sctx.delays in
+		sctx.delays <- [];
+		List.iter (fun f -> f()) fl
+
+	let is_removed_module sctx m =
+		List.exists (fun (_,m') -> m == m') sctx.removed_modules
+
+	let reset sctx =
+		Hashtbl.clear sctx.changed_directories;
+		sctx.was_compilation <- false
+end
+
+open ServerCompilationContext
+
+let stat dir =
+	(Unix.stat (Path.remove_trailing_slash dir)).Unix.st_mtime
+
+(* Gets a list of changed directories for the current compilation. *)
+let get_changed_directories sctx (ctx : Typecore.typer) =
+	let t = Timer.timer ["server";"module cache";"changed dirs"] in
+	let cs = sctx.cs in
+	let com = ctx.Typecore.com in
+	let sign = Define.get_signature com.defines in
+	let dirs = try
+		(* First, check if we already have determined changed directories for current compilation. *)
+		Hashtbl.find sctx.changed_directories sign
+	with Not_found ->
+		let dirs = try
+			(* Next, get all directories from the cache and filter the ones that haven't changed. *)
+			let all_dirs = CompilationServer.find_directories cs sign in
+			let dirs = List.fold_left (fun acc dir ->
 				try
-					let cfile = CompilationServer.find_file cs fkey in
-					if cfile.c_time <> ftime then raise Not_found;
-					Parser.ParseSuccess(cfile.c_package,cfile.c_decls)
-				with Not_found ->
-					let parse_result = TypeloadParse.parse_file com2 file p in
-					let info,is_unusual = match parse_result with
-						| ParseError(_,_,_) -> "not cached, has parse error",true
-						| ParseDisplayFile _ -> "not cached, is display file",true
-						| ParseSuccess data ->
-							begin try
-								(* We assume that when not in display mode it's okay to cache stuff that has #if display
-								checks. The reasoning is that non-display mode has more information than display mode. *)
-								if not com2.display.dms_display then raise Not_found;
-								let ident = Hashtbl.find Parser.special_identifier_files ffile in
-								Printf.sprintf "not cached, using \"%s\" define" ident,true
-							with Not_found ->
-								CompilationServer.cache_file cs fkey ftime data;
-								"cached",false
-							end
-					in
-					if is_unusual then ServerMessage.parsed com2 "" (ffile,info);
-					parse_result
-			) () in
-			data
-	);
-	let check_module_shadowing com paths m =
+					let time' = stat dir.c_path in
+					if dir.c_mtime < time' then begin
+						dir.c_mtime <- time';
+						let sub_dirs = Path.find_directories (platform_name com.platform) false [dir.c_path] in
+						List.iter (fun dir ->
+							if not (CompilationServer.has_directory cs sign dir) then begin
+								let time = stat dir in
+								ServerMessage.added_directory com "" dir;
+								CompilationServer.add_directory cs sign (CompilationServer.create_directory dir time)
+							end;
+						) sub_dirs;
+						(CompilationServer.create_directory dir.c_path time') :: acc
+					end else
+						acc
+				with Unix.Unix_error _ ->
+					CompilationServer.remove_directory cs sign dir.c_path;
+					ServerMessage.removed_directory com "" dir.c_path;
+					acc
+			) [] all_dirs in
+			ServerMessage.changed_directories com "" dirs;
+			dirs
+		with Not_found ->
+			(* There were no directories in the cache, so this must be a new context. Let's add
+				an empty list to make sure no crazy recursion happens. *)
+			CompilationServer.add_directories cs sign [];
+			(* Register the delay that is going to populate the cache dirs. *)
+			sctx.delays <- (fun () ->
+				let dirs = ref [] in
+				let add_dir path =
+					try
+						let time = stat path in
+						dirs := CompilationServer.create_directory path time :: !dirs
+					with Unix.Unix_error _ ->
+						()
+				in
+				List.iter add_dir com.class_path;
+				List.iter add_dir (Path.find_directories (platform_name com.platform) true com.class_path);
+				ServerMessage.found_directories com "" !dirs;
+				CompilationServer.add_directories cs sign !dirs
+			) :: sctx.delays;
+			(* Returning [] should be fine here because it's a new context, so we won't do any
+				shadowing checks anyway. *)
+			[]
+		in
+		Hashtbl.add sctx.changed_directories sign dirs;
+		dirs
+	in
+	t();
+	dirs
+
+(* Checks if module [m] can be reused from the cache and returns None in that case. Otherwise, returns
+   [Some m'] where [m'] is the module responsible for [m] not being reusable. *)
+let check_module sctx ctx m p =
+	let com = ctx.Typecore.com in
+	let cs = sctx.cs in
+	let sign = Define.get_signature com.defines in
+	let content_changed m file =
+		let ffile = Path.unique_full_path file in
+		let fkey = (ffile,sign) in
+		try
+			let cfile = CompilationServer.find_file cs fkey in
+			(* We must use the module path here because the file path is absolute and would cause
+				positions in the parsed declarations to differ. *)
+			let new_data = TypeloadParse.parse_module ctx m.m_path p in
+			cfile.c_decls <> snd new_data
+		with Not_found ->
+			true
+	in
+	let check_module_shadowing paths m =
 		List.iter (fun dir ->
 			let file = (dir.c_path ^ (snd m.m_path)) ^ ".hx" in
 			if Sys.file_exists file then begin
@@ -185,313 +321,269 @@ let rec wait_loop process_params verbose accept =
 			end
 		) paths
 	in
-	let delays = ref [] in
-	let changed_directories = Hashtbl.create 0 in
-	let arguments = Hashtbl.create 0 in
-	let stat dir =
-		(Unix.stat (Path.remove_trailing_slash dir)).Unix.st_mtime
-	in
-	let get_changed_directories (ctx : Typecore.typer) =
-		let t = Timer.timer ["server";"module cache";"changed dirs"] in
-		let com = ctx.Typecore.com in
-		let sign = Define.get_signature com.defines in
-		let dirs = try
-			(* First, check if we already have determined changed directories for current compilation. *)
-			Hashtbl.find changed_directories sign
-		with Not_found ->
-			let dirs = try
-				(* Next, get all directories from the cache and filter the ones that haven't changed. *)
-				let all_dirs = CompilationServer.find_directories cs sign in
-				let dirs = List.fold_left (fun acc dir ->
-					try
-						let time' = stat dir.c_path in
-						if dir.c_mtime < time' then begin
-							dir.c_mtime <- time';
-							let sub_dirs = Path.find_directories (platform_name com.platform) false [dir.c_path] in
-							List.iter (fun dir ->
-								if not (CompilationServer.has_directory cs sign dir) then begin
-									let time = stat dir in
-									ServerMessage.added_directory com "" dir;
-									CompilationServer.add_directory cs sign (CompilationServer.create_directory dir time)
-								end;
-							) sub_dirs;
-							(CompilationServer.create_directory dir.c_path time') :: acc
-						end else
-							acc
-					with Unix.Unix_error _ ->
-						CompilationServer.remove_directory cs sign dir.c_path;
-						ServerMessage.removed_directory com "" dir.c_path;
-						acc
-				) [] all_dirs in
-				ServerMessage.changed_directories com "" dirs;
-				dirs
-			with Not_found ->
-				(* There were no directories in the cache, so this must be a new context. Let's add
-				   an empty list to make sure no crazy recursion happens. *)
-				CompilationServer.add_directories cs sign [];
-				(* Register the delay that is going to populate the cache dirs. *)
-				delays := (fun () ->
-					let dirs = ref [] in
-					let add_dir path =
-						try
-							let time = stat path in
-							dirs := CompilationServer.create_directory path time :: !dirs
-						with Unix.Unix_error _ ->
-							()
-					in
-					List.iter add_dir com.class_path;
-					List.iter add_dir (Path.find_directories (platform_name com.platform) true com.class_path);
-					ServerMessage.found_directories com "" !dirs;
-					CompilationServer.add_directories cs sign !dirs
-				) :: !delays;
-				(* Returning [] should be fine here because it's a new context, so we won't do any
-				   shadowing checks anyway. *)
-				[]
-			in
-			Hashtbl.add changed_directories sign dirs;
-			dirs
+	let mark = sctx.mark_loop in
+	let start_mark = sctx.compilation_mark in
+	let rec check m =
+		let check_module_path () =
+			let directories = get_changed_directories sctx ctx in
+			match m.m_extra.m_kind with
+			| MFake | MImport -> () (* don't get classpath *)
+			| MExtern ->
+				(* if we have a file then this will override our extern type *)
+				let has_file = (try check_module_shadowing directories m; false with Not_found -> true) in
+				if has_file then begin
+					if sctx.verbose then print_endline ("A file is masking the library file " ^ s_type_path m.m_path); (* TODO *)
+					raise Not_found;
+				end;
+				let rec loop = function
+					| [] ->
+						if sctx.verbose then print_endline ("No library file was found for " ^ s_type_path m.m_path); (* TODO *)
+						raise Not_found (* no extern registration *)
+					| (file,load) :: l ->
+						match load m.m_path p with
+						| None -> loop l
+						| Some _ ->
+							if Path.unique_full_path file <> m.m_extra.m_file then begin
+								if sctx.verbose then print_endline ("Library file was changed for " ^ s_type_path m.m_path); (* TODO *)
+								raise Not_found;
+							end
+				in
+				loop com.load_extern_type
+			| MCode -> check_module_shadowing directories m
+			| MMacro when ctx.Typecore.in_macro -> check_module_shadowing directories m
+			| MMacro ->
+				(*
+					Creating another context while the previous one is incomplete means we have an infinite loop in the compiler.
+					Most likely because of circular dependencies in base modules (e.g. `StdTypes` or `String`)
+					Prevents spending another 5 hours for debugging.
+					@see https://github.com/HaxeFoundation/haxe/issues/8174
+				*)
+				if not ctx.g.complete && ctx.in_macro then
+					raise (ServerError ("Infinite loop in Haxe server detected. "
+						^ "Probably caused by shadowing a module of the standard library. "
+						^ "Make sure shadowed module does not pull macro context."));
+				let _, mctx = MacroContext.get_macro_context ctx p in
+				check_module_shadowing (get_changed_directories sctx mctx) m
 		in
-		t();
-		dirs
-	in
-	let compilation_step = ref 0 in
-	let compilation_mark = ref 0 in
-	let mark_loop = ref 0 in
-	let removed_modules = ref [] in
-	let is_removed_module m = List.exists (fun (_,m') -> m == m') !removed_modules in
-	TypeloadModule.type_module_hook := (fun (ctx:Typecore.typer) mpath p ->
-		let t = Timer.timer ["server";"module cache"] in
-		let com2 = ctx.Typecore.com in
-		let sign = Define.get_signature com2.defines in
-		let content_changed m file =
-			let ffile = Path.unique_full_path file in
-			let fkey = (ffile,sign) in
-			try
-				let cfile = CompilationServer.find_file cs fkey in
-				(* We must use the module path here because the file path is absolute and would cause
-				   positions in the parsed declarations to differ. *)
-				let new_data = TypeloadParse.parse_module ctx m.m_path p in
-				cfile.c_decls <> snd new_data
-			with Not_found ->
-				true
+		let has_policy policy = List.mem policy m.m_extra.m_check_policy || match policy with
+			| NoCheckShadowing | NoCheckFileTimeModification when !ServerConfig.do_not_check_modules && !Parser.display_mode <> DMNone -> true
+			| _ -> false
 		in
-		incr mark_loop;
-		let mark = !mark_loop in
-		let start_mark = !compilation_mark in
-		let rec check m =
-			let check_module_path () =
-				let directories = get_changed_directories ctx in
-				match m.m_extra.m_kind with
-				| MFake | MImport -> () (* don't get classpath *)
-				| MExtern ->
-					(* if we have a file then this will override our extern type *)
-					let has_file = (try check_module_shadowing com2 directories m; false with Not_found -> true) in
-					if has_file then begin
-						if verbose then print_endline ("A file is masking the library file " ^ s_type_path m.m_path); (* TODO *)
-						raise Not_found;
-					end;
-					let rec loop = function
-						| [] ->
-							if verbose then print_endline ("No library file was found for " ^ s_type_path m.m_path); (* TODO *)
-							raise Not_found (* no extern registration *)
-						| (file,load) :: l ->
-							match load m.m_path p with
-							| None -> loop l
-							| Some _ ->
-								if Path.unique_full_path file <> m.m_extra.m_file then begin
-									if verbose then print_endline ("Library file was changed for " ^ s_type_path m.m_path); (* TODO *)
-									raise Not_found;
-								end
-					in
-					loop com2.load_extern_type
-				| MCode -> check_module_shadowing com2 directories m
-				| MMacro when ctx.Typecore.in_macro -> check_module_shadowing com2 directories m
-				| MMacro ->
-					(*
-						Creating another context while the previous one is incomplete means we have an infinite loop in the compiler.
-						Most likely because of circular dependencies in base modules (e.g. `StdTypes` or `String`)
-						Prevents spending another 5 hours for debugging.
-						@see https://github.com/HaxeFoundation/haxe/issues/8174
-					*)
-					if not ctx.g.complete && ctx.in_macro then
-						raise (ServerError ("Infinite loop in Haxe server detected. "
-							^ "Probably caused by shadowing a module of the standard library. "
-							^ "Make sure shadowed module does not pull macro context."));
-					let _, mctx = MacroContext.get_macro_context ctx p in
-					check_module_shadowing mctx.Typecore.com (get_changed_directories mctx) m
-			in
-			let has_policy policy = List.mem policy m.m_extra.m_check_policy || match policy with
-				| NoCheckShadowing | NoCheckFileTimeModification when !ServerConfig.do_not_check_modules && !Parser.display_mode <> DMNone -> true
-				| _ -> false
-			in
-			let check_file () =
-				if file_time m.m_extra.m_file <> m.m_extra.m_time then begin
-					if has_policy CheckFileContentModification && not (content_changed m m.m_extra.m_file) then begin
-						ServerMessage.unchanged_content com2 "" m.m_extra.m_file;
-					end else begin
-						ServerMessage.not_cached com2 "" m;
-						if m.m_extra.m_kind = MFake then Hashtbl.remove Typecore.fake_modules m.m_extra.m_file;
-						raise Not_found;
-					end
-				end
-			in
-			let check_dependencies () =
-				PMap.iter (fun _ m2 -> match check m2 with
-					| None -> ()
-					| Some m -> raise (Dirty m)
-				) m.m_extra.m_deps;
-			in
-			begin match m.m_extra.m_dirty with
-			| Some m ->
-				Some m
-			| None ->
-				if m.m_extra.m_mark = mark then
-					None
-				else try
-					let old_mark = m.m_extra.m_mark in
-					m.m_extra.m_mark <- mark;
-					if old_mark <= start_mark then begin
-						(* Workaround for preview.4 Java issue *)
-						begin match m.m_extra.m_kind with
-							| MExtern -> check_module_path()
-							| _ -> if not (has_policy NoCheckShadowing) then check_module_path();
-						end;
-						if not (has_policy NoCheckFileTimeModification) then check_file();
-					end;
-					if not (has_policy NoCheckDependencies) then check_dependencies();
-					None
-				with
-				| Not_found ->
-					m.m_extra.m_dirty <- Some m;
-					Some m
-				| Dirty m' ->
-					m.m_extra.m_dirty <- Some m';
-					Some m'
+		let check_file () =
+			if file_time m.m_extra.m_file <> m.m_extra.m_time then begin
+				if has_policy CheckFileContentModification && not (content_changed m m.m_extra.m_file) then begin
+					ServerMessage.unchanged_content com "" m.m_extra.m_file;
+				end else begin
+					ServerMessage.not_cached com "" m;
+					if m.m_extra.m_kind = MFake then Hashtbl.remove Typecore.fake_modules m.m_extra.m_file;
+					raise Not_found;
 				end
-		in
-		let rec add_modules tabs m0 m =
-			if m.m_extra.m_added < !compilation_step then begin
-				(match m0.m_extra.m_kind, m.m_extra.m_kind with
-				| MCode, MMacro | MMacro, MCode ->
-					(* this was just a dependency to check : do not add to the context *)
-					PMap.iter (Hashtbl.replace com2.resources) m.m_extra.m_binded_res;
-				| _ when is_removed_module m ->
-					()
-				| _ ->
-					ServerMessage.reusing com2 tabs m;
-					m.m_extra.m_added <- !compilation_step;
-					List.iter (fun t ->
-						match t with
-						| TClassDecl c -> c.cl_restore()
-						| TEnumDecl e ->
-							let rec loop acc = function
-								| [] -> ()
-								| (Meta.RealPath,[Ast.EConst (Ast.String path),_],_) :: l ->
-									e.e_path <- Ast.parse_path path;
-									e.e_meta <- (List.rev acc) @ l;
-								| x :: l -> loop (x::acc) l
-							in
-							loop [] e.e_meta
-						| TAbstractDecl a ->
-							a.a_meta <- List.filter (fun (m,_,_) -> m <> Meta.ValueUsed) a.a_meta
-						| _ -> ()
-					) m.m_types;
-					TypeloadModule.add_module ctx m p;
-					PMap.iter (Hashtbl.replace com2.resources) m.m_extra.m_binded_res;
-					PMap.iter (fun _ m2 -> add_modules (tabs ^ "  ") m0 m2) m.m_extra.m_deps
-				)
 			end
 		in
+		let check_dependencies () =
+			PMap.iter (fun _ m2 -> match check m2 with
+				| None -> ()
+				| Some m -> raise (Dirty m)
+			) m.m_extra.m_deps;
+		in
+		begin match m.m_extra.m_dirty with
+		| Some m ->
+			Some m
+		| None ->
+			if m.m_extra.m_mark = mark then
+				None
+			else try
+				let old_mark = m.m_extra.m_mark in
+				m.m_extra.m_mark <- mark;
+				if old_mark <= start_mark then begin
+					(* Workaround for preview.4 Java issue *)
+					begin match m.m_extra.m_kind with
+						| MExtern -> check_module_path()
+						| _ -> if not (has_policy NoCheckShadowing) then check_module_path();
+					end;
+					if not (has_policy NoCheckFileTimeModification) then check_file();
+				end;
+				if not (has_policy NoCheckDependencies) then check_dependencies();
+				None
+			with
+			| Not_found ->
+				m.m_extra.m_dirty <- Some m;
+				Some m
+			| Dirty m' ->
+				m.m_extra.m_dirty <- Some m';
+				Some m'
+			end
+	in
+	check m
+
+(* Adds module [m] and all its dependencies (recursively) from the cache to the current compilation
+   context. *)
+let add_modules sctx ctx m p =
+	let com = ctx.Typecore.com in
+	let rec add_modules tabs m0 m =
+		if m.m_extra.m_added < sctx.compilation_step then begin
+			(match m0.m_extra.m_kind, m.m_extra.m_kind with
+			| MCode, MMacro | MMacro, MCode ->
+				(* this was just a dependency to check : do not add to the context *)
+				PMap.iter (Hashtbl.replace com.resources) m.m_extra.m_binded_res;
+			| _ when is_removed_module sctx m ->
+				()
+			| _ ->
+				ServerMessage.reusing com tabs m;
+				m.m_extra.m_added <- sctx.compilation_step;
+				List.iter (fun t ->
+					match t with
+					| TClassDecl c -> c.cl_restore()
+					| TEnumDecl e ->
+						let rec loop acc = function
+							| [] -> ()
+							| (Meta.RealPath,[Ast.EConst (Ast.String path),_],_) :: l ->
+								e.e_path <- Ast.parse_path path;
+								e.e_meta <- (List.rev acc) @ l;
+							| x :: l -> loop (x::acc) l
+						in
+						loop [] e.e_meta
+					| TAbstractDecl a ->
+						a.a_meta <- List.filter (fun (m,_,_) -> m <> Meta.ValueUsed) a.a_meta
+					| _ -> ()
+				) m.m_types;
+				TypeloadModule.add_module ctx m p;
+				PMap.iter (Hashtbl.replace com.resources) m.m_extra.m_binded_res;
+				PMap.iter (fun _ m2 -> add_modules (tabs ^ "  ") m0 m2) m.m_extra.m_deps
+			)
+		end
+	in
+	add_modules "" m m
+
+(* Looks up the module referred to by [mpath] in the cache. If it exists, a check is made to
+   determine if it's still valid. If this function returns None, the module is re-typed. *)
+let type_module sctx (ctx:Typecore.typer) mpath p =
+	let t = Timer.timer ["server";"module cache"] in
+	let com = ctx.Typecore.com in
+	let cs = sctx.cs in
+	let sign = Define.get_signature com.defines in
+	sctx.mark_loop <- sctx.mark_loop + 1;
+	try
+		let m = CompilationServer.find_module cs (mpath,sign) in
+		let tcheck = Timer.timer ["server";"module cache";"check"] in
+		begin match check_module sctx ctx m p with
+		| None -> ()
+		| Some m' ->
+			ServerMessage.skipping_dep com "" (m,m');
+			tcheck();
+			raise Not_found;
+		end;
+		tcheck();
+		let tadd = Timer.timer ["server";"module cache";"add modules"] in
+		add_modules sctx ctx m p;
+		tadd();
+		t();
+		Some m
+	with Not_found ->
+		t();
+		None
+
+(* Sets up the per-compilation context. *)
+let create sctx write params =
+	let cs = sctx.cs in
+	let recache_removed_modules () =
+		List.iter (fun (k,m) ->
+			try
+				ignore(CompilationServer.find_module sctx.cs k);
+			with Not_found ->
+				CompilationServer.cache_module sctx.cs k m
+		) sctx.removed_modules;
+		sctx.removed_modules <- []
+	in
+	let maybe_cache_context com =
+		if com.display.dms_full_typing then begin
+			CompilationServer.cache_context sctx.cs com;
+			ServerMessage.cached_modules com "" (List.length com.modules);
+			sctx.removed_modules <- [];
+		end else
+			recache_removed_modules ()
+	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);
+		(* Special case for diagnostics: It's not treated as a display mode, but we still want to invalidate the
+			current file in order to run diagnostics on it again. *)
+		if ctx.com.display.dms_display || (match ctx.com.display.dms_kind with DMDiagnostics _ -> true | _ -> false) then begin
+			let file = (DisplayPosition.display_position#get).pfile in
+			let fkey = (file,sign) in
+			(* force parsing again : if the completion point have been changed *)
+			CompilationServer.remove_file cs fkey;
+			sctx.removed_modules <- CompilationServer.filter_modules cs file;
+			add_delay sctx recache_removed_modules;
+		end;
 		try
-			let m = CompilationServer.find_module cs (mpath,sign) in
-			let tcheck = Timer.timer ["server";"module cache";"check"] in
-			begin match check m with
-			| None -> ()
-			| Some m' ->
-				ServerMessage.skipping_dep com2 "" (m,m');
-				tcheck();
-				raise Not_found;
+			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;
+				CompilationServer.clear_directories cs sign;
 			end;
-			tcheck();
-			let tadd = Timer.timer ["server";"module cache";"add modules"] in
-			add_modules "" m m;
-			tadd();
-			t();
-			Some m
 		with Not_found ->
-			t();
-			None
+			Hashtbl.add sctx.class_paths sign ctx.com.class_path;
+			()
 	);
+	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()
+
+(* 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 =
+	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 *)
+	let cs = CompilationServer.create () in
+	let sctx = ServerCompilationContext.create verbose cs in
+	TypeloadModule.type_module_hook := type_module sctx;
+	MacroContext.macro_enable_cache := true;
+	TypeloadParse.parse_hook := parse_file cs;
 	let run_count = ref 0 in
+	(* Main loop: accept connections and process arguments *)
 	while true do
 		let read, write, close = accept() in
-		let was_compilation = ref false in
-		let recache_removed_modules () =
-			List.iter (fun (k,m) ->
-				try
-					ignore(CompilationServer.find_module cs k);
-				with Not_found ->
-					CompilationServer.cache_module cs k m
-			) !removed_modules;
-			removed_modules := [];
-		in
-		let maybe_cache_context com =
-			if com.display.dms_full_typing then begin
-				CompilationServer.cache_context cs com;
-				ServerMessage.cached_modules com "" (List.length com.modules);
-				removed_modules := [];
-			end else
-				recache_removed_modules();
-		in
-		let create params =
-			let ctx = create_context params in
-			ctx.flush <- (fun() ->
-				incr compilation_step;
-				compilation_mark := !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);
-					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);
-				(* Special case for diagnostics: It's not treated as a display mode, but we still want to invalidate the
-				   current file in order to run diagnostics on it again. *)
-				if ctx.com.display.dms_display || (match ctx.com.display.dms_kind with DMDiagnostics _ -> true | _ -> false) then begin
-					let file = (DisplayPosition.display_position#get).pfile in
-					let fkey = (file,sign) in
-					(* force parsing again : if the completion point have been changed *)
-					CompilationServer.remove_file cs fkey;
-					removed_modules := CompilationServer.filter_modules cs file;
-					delays := recache_removed_modules :: !delays;
-				end;
-				try
-					if (Hashtbl.find arguments sign) <> ctx.com.class_path then begin
-						ServerMessage.class_paths_changed ctx.com "";
-						Hashtbl.replace arguments sign ctx.com.class_path;
-						CompilationServer.clear_directories cs sign;
-					end;
-				with Not_found ->
-					Hashtbl.add arguments sign ctx.com.class_path;
-					()
-			);
-			ctx.com.print <- (fun str -> write ("\x01" ^ String.concat "\x01" (ExtString.String.nsplit str "\n") ^ "\n"));
-			ctx
-		in
-		(try
+		begin try
+			(* Read arguments *)
 			let s = read() in
 			let t0 = get_time() in
 			let hxml =
@@ -504,22 +596,10 @@ let rec wait_loop process_params verbose accept =
 			in
 			let data = parse_hxml_data hxml in
 			ServerMessage.arguments data;
-			(try
-				Hashtbl.clear changed_directories;
-				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;
-				let _ = Timer.timer ["other"] in
-				incr compilation_step;
-				compilation_mark := !mark_loop;
-				start_time := get_time();
+			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"))
@@ -529,11 +609,9 @@ let rec wait_loop process_params verbose accept =
 				write str
 			| Arg.Bad msg ->
 				print_endline ("Error: " ^ msg);
-			);
-			let fl = !delays in
-			delays := [];
-			List.iter (fun f -> f()) fl;
-			ServerMessage.stats stats (get_time() -. t0);
+			end;
+			run_delays sctx;
+			ServerMessage.stats stats (get_time() -. t0)
 		with Unix.Unix_error _ ->
 			ServerMessage.socket_message "Connection Aborted"
 		| e ->
@@ -545,11 +623,12 @@ let rec wait_loop process_params verbose accept =
 				close();
 				exit (-1);
 			end;
-		);
+		end;
+		(* Close connection and perform some cleanup *)
 		close();
 		current_stdin := None;
 		(* prevent too much fragmentation by doing some compactions every X run *)
-		if !was_compilation then incr run_count;
+		if sctx.was_compilation then incr run_count;
 		if !run_count mod 10 = 0 then begin
 			run_count := 1;
 			let t0 = get_time() in
@@ -558,7 +637,8 @@ let rec wait_loop process_params verbose accept =
 		end else Gc.minor();
 	done
 
-and init_wait_stdio() =
+(* 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;
 
@@ -580,7 +660,8 @@ and init_wait_stdio() =
 		Buffer.clear berr;
 		read, write, close
 
-and init_wait_socket host port =
+(* The accept-function to wait for a socket connection. *)
+let 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));
@@ -622,7 +703,8 @@ and init_wait_socket host port =
 	) in
 	accept
 
-and do_connect host port args =
+(* 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 args = ("--cwd " ^ Unix.getcwd()) :: args in