Log whenever managed objects are garbage collected

7 files changed, 62 insertions, 7 deletions

diff --git a/lib/Logger.ml b/lib/Logger.ml
new file mode 100644
index 0000000..ebb6c97
--- /dev/null
+++ b/lib/Logger.ml
@@ -0,0 +1,29 @@
+type level = Debug | Info | Warn | Error | Fatal
+
+type colors = Foreground | Blue | Yellow | Red | Purple
+
+let reset = "\027[0m"
+let bold = "\027[1m"
+
+let color_for = function
+  | Foreground -> "\027[39m"
+  | Blue -> "\027[34m"
+  | Yellow -> "\027[33m"
+  | Red -> "\027[31m"
+  | Purple -> "\027[35m"
+
+let colored color text = Printf.sprintf "%s%s%s%s" (color_for color) bold text reset
+
+let channel_for = function
+  | Warn | Error | Fatal -> stderr
+  | _ -> stdout
+
+let prefix_for = function
+  | Debug -> colored Foreground "[DEBUG]"
+  | Info -> colored Blue "[INFO]"
+  | Warn -> colored Yellow "[WARN]"
+  | Error -> colored Red "[ERROR]"
+  | Fatal -> colored Purple "[FATAL]"
+
+let log level message =
+  Printf.fprintf (channel_for level) "%s %s\n" (prefix_for level) message
diff --git a/lib/Logger.mli b/lib/Logger.mli
new file mode 100644
index 0000000..21d5b73
--- /dev/null
+++ b/lib/Logger.mli
@@ -0,0 +1,3 @@
+type level = Debug | Info | Warn | Error | Fatal
+
+val log : level -> string -> unit
diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml
index ac6bb20..4fb12b9 100644
--- a/lib/kernel/Lifecycle.ml
+++ b/lib/kernel/Lifecycle.ml
@@ -1,6 +1,7 @@
 class type lifecycle = object
   method reference : bool
   method release : unit
+  method is_managed : bool
 end
 
 class type virtual controlled_lifecycle = object
@@ -12,6 +13,7 @@ class null =
   object
     method reference = true
     method release = ()
+    method is_managed = false
   end
 
 class exclusive =
@@ -19,6 +21,7 @@ class exclusive =
     val taken = Atomic.make false
     method reference = Atomic.compare_and_set taken false true
     method release = Atomic.set taken false
+    method is_managed = true
   end
 
 class virtual counted =
@@ -27,6 +30,7 @@ class virtual counted =
     method virtual destroy : unit
     method reference = Atomic.incr references; true
     method release = if Atomic.fetch_and_add references (-1) = 1 then self#destroy
+    method is_managed = true
   end
 
 class retaining inner (owner : lifecycle) =
diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli
index d4ef178..a323197 100644
--- a/lib/kernel/Lifecycle.mli
+++ b/lib/kernel/Lifecycle.mli
@@ -1,6 +1,7 @@
 class type lifecycle = object
   method reference : bool
   method release : unit
+  method is_managed : bool
 end
 
 class type virtual controlled_lifecycle = object
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index add2e1c..9ded873 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -12,19 +12,37 @@ end
 class type obj = object
   method reference : bool
   method release : unit
+  method is_managed : bool
   method hash : Concepts.Hash.hash
   method to_string : string
   method protocols : protocol list
 end
 
-type t = {valid: bool Atomic.t; refers_to: obj}
+type t = {valid: bool Atomic.t; refers_to: obj; allocated_at: Printexc.raw_backtrace}
 type 'a interface = {handle: t; interface: 'a}
 
-let object_of {valid; refers_to} =
+let object_of {valid; refers_to; _} =
   if (Atomic.get valid) then refers_to else failwith "Attempt to dereference an invalid handle!"
 
+let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">"
+
+let on_gc ({valid; refers_to; allocated_at} as h) =
+  (* TODO: get rid of this on release builds *)
+  if refers_to#is_managed && (Atomic.get valid) then begin
+      Logger.(log Warn ("Leaking handle to managed object " ^ (to_string h)));
+      Logger.(log Warn (BatString.nreplace
+                          (* bleh *)
+                          ~str:(Printexc.raw_backtrace_to_string allocated_at)
+                          ~sub:"Raised by primitive operation"
+                          ~by:"Allocated"))
+    end
+
 let interface_of handle interface = {handle; interface}
-let make o = {valid= Atomic.make true; refers_to= (o :> obj)}
+let make o =
+  let h = {valid= Atomic.make true; refers_to= (o :> obj); allocated_at= Printexc.get_callstack 256} in
+  Gc.finalise on_gc h;
+  h
+
 let into handle f = List.find_map f (object_of handle)#protocols |> Option.map (interface_of handle)
 
 let invoke {handle; interface} f =
@@ -40,7 +58,6 @@ let copy handle =
 let equal h1 h2 = Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash
 let hash h = (object_of h)#hash
 let protocols h = (object_of h)#protocols
-let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">"
 
 let release ({valid; _} as handle) =
   let o = object_of handle in
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
index a354257..f413aac 100644
--- a/lib/protocols/Handle.mli
+++ b/lib/protocols/Handle.mli
@@ -5,6 +5,7 @@ type protocol = ..
 class type obj = object
   method reference : bool
   method release : unit
+  method is_managed : bool
   method hash : Concepts.Hash.hash
   method to_string : string
   method protocols : protocol list
diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml
index 7f113ef..d7ffa92 100644
--- a/test/unit/kernel/EphemeralRelation.ml
+++ b/test/unit/kernel/EphemeralRelation.ml
@@ -97,9 +97,9 @@ let releasing_releases_its_inputs () =
   let released = ref false in
   let input =
     object
-      method reference = true
-      method release = released := true
-      method hash = Concepts.Hash.hash_of_int 0
+      inherit Rnt.Kernel.Lifecycle.null
+      inherit Rnt.Kernel.Identity.of_id
+      method! release = released := true
       method to_string = "input"
       method protocols : Protocols.Handle.protocol list = []
     end