Преглед изворни кода

[typer] add memory marker for typer context

Simon Krajewski пре 6 година
родитељ
комит
e2cd308453
4 измењених фајлова са 7 додато и 1 уклоњено
  1. 2 1
      src/context/memory.ml
  2. 3 0
      src/context/typecore.ml
  3. 1 0
      src/typing/typeloadModule.ml
  4. 1 0
      src/typing/typer.ml

+ 2 - 1
src/context/memory.ml

@@ -51,13 +51,14 @@ let collect_leaks m deps out =
 		leaks := s :: !leaks
 	in
 	if (Objsize.objsize m deps [Obj.repr Common.memory_marker]).Objsize.reached then leak "common";
+	if (Objsize.objsize m deps [Obj.repr Typecore.memory_marker]).Objsize.reached then leak "typecore";
 	PMap.iter (fun _ md ->
 		if (Objsize.objsize m deps [Obj.repr md]).Objsize.reached then leak (s_type_path md.m_path ^ module_sign m.m_extra.m_sign md);
 	) out;
 	!leaks
 
 let get_out out =
-	Obj.repr Common.memory_marker :: PMap.fold (fun m acc -> Obj.repr m :: acc) out []
+	Obj.repr Common.memory_marker :: Obj.repr Typecore.memory_marker :: PMap.fold (fun m acc -> Obj.repr m :: acc) out []
 
 let get_module_memory cs all_modules m =
 	let mdeps = Hashtbl.create 0 in

+ 3 - 0
src/context/typecore.ml

@@ -133,11 +133,14 @@ and typer = {
 	mutable in_call_args : bool;
 	(* events *)
 	mutable on_error : typer -> string -> pos -> unit;
+	memory_marker : float array;
 }
 exception Forbid_package of (string * path * pos) * pos list * string
 
 exception WithTypeError of error_msg * pos
 
+let memory_marker = [|Unix.time()|]
+
 let make_call_ref : (typer -> texpr -> texpr list -> t -> ?force_inline:bool -> pos -> texpr) ref = ref (fun _ _ _ _ ?force_inline:bool _ -> assert false)
 let type_expr_ref : (?mode:access_mode -> typer -> expr -> WithType.t -> texpr) ref = ref (fun ?(mode=MGet) _ _ _ -> assert false)
 let type_block_ref : (typer -> expr list -> WithType.t -> pos -> texpr) ref = ref (fun _ _ _ _ -> assert false)

+ 1 - 0
src/typing/typeloadModule.ml

@@ -872,6 +872,7 @@ let type_types_into_module ctx m tdecls p =
 		opened = [];
 		in_call_args = false;
 		vthis = None;
+		memory_marker = Typecore.memory_marker;
 	} in
 	if ctx.g.std != null_module then begin
 		add_dependency m ctx.g.std;

+ 1 - 0
src/typing/typer.ml

@@ -2651,6 +2651,7 @@ let rec create com =
 		vthis = None;
 		in_call_args = false;
 		on_error = (fun ctx msg p -> ctx.com.error msg p);
+		memory_marker = Typecore.memory_marker;
 	} in
 	ctx.g.std <- (try
 		TypeloadModule.load_module ctx ([],"StdTypes") null_pos