merge lifecycle-ergonomics and rework modes and contain checks

6 files changed, 66 insertions, 13 deletions

diff --git a/lib/protocols/Admission.ml b/lib/protocols/Admission.ml
index 5a20105..c29f192 100644
--- a/lib/protocols/Admission.ml
+++ b/lib/protocols/Admission.ml
@@ -6,7 +6,7 @@ module Error = struct
       empty
 end
 
-type violations = (string * Concepts.Tuple.t list) list
+type violations = (string * Concepts.Tuple.t) list
 
 class type implementation = object
   method check : (violations, Concepts.Condition.condition) result
diff --git a/lib/protocols/Admission.mli b/lib/protocols/Admission.mli
index 235eae7..7f0c596 100644
--- a/lib/protocols/Admission.mli
+++ b/lib/protocols/Admission.mli
@@ -1,5 +1,5 @@
 type t
-type violations = (string * Concepts.Tuple.t list) list
+type violations = (string * Concepts.Tuple.t) list
 
 class type implementation = object
   method check : (violations, Concepts.Condition.condition) result
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index c8480a6..0c5f3cc 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -12,19 +12,65 @@ 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 ref; 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} =
-  if !valid then refers_to else failwith "Attempt to dereference an invalid handle!"
+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 invalidate {valid; _} = Atomic.compare_and_set valid true false
+
+let release handle =
+  let o = object_of handle in
+  if invalidate handle then o#release
+
+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" ) );
+    release h
+  end
+
+type _ Effect.t += Autorelease : t -> unit Effect.t | Keep : t -> unit Effect.t
+
+let with_autorelease f =
+  let hs = Atomic.make BatSet.empty in
+  Fun.protect
+    ~finally:(fun () -> Atomic.get hs |> BatSet.iter release)
+    (fun () ->
+      try f () with
+      | effect Autorelease h, k ->
+          Utilities.Atomic.swap hs (fun ft -> BatSet.add h ft) |> ignore;
+          Effect.Deep.continue k ()
+      | effect Keep h, k ->
+          Utilities.Atomic.swap hs (fun ft -> BatSet.remove h ft) |> ignore;
+          Effect.Deep.continue k () )
+
+let keep h = Effect.perform (Keep h); h
+let autorelease h = Effect.perform (Autorelease h); h
 let interface_of handle interface = {handle; interface}
-let make o = {valid= ref 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 =
@@ -37,15 +83,13 @@ let copy handle =
   let o = object_of handle in
   if o#reference then Some (make o) else None
 
+let move handle =
+  let o = object_of handle in
+  invalidate handle |> ignore;
+  make o
+
 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 = (object_of h)#to_string
-
-let release ({valid; _} as handle) =
-  let o = object_of handle in
-  valid := false;
-  o#release
-
 let releasing handle f = Fun.protect ~finally:(fun () -> release handle) f
 let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h)
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
index 5c74521..94734e4 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
@@ -15,6 +16,7 @@ val into : t -> (protocol -> 'a option) -> 'a interface option
 val from : 'a interface -> t
 val invoke : 'a interface -> ('a -> 'b) -> 'b
 val copy : t -> t option
+val move : t -> t
 val equal : t -> t -> bool
 val release : t -> unit
 val releasing : t -> (unit -> 'a) -> 'a
@@ -22,3 +24,6 @@ val hash : t -> Concepts.Hash.hash
 val protocols : t -> protocol list
 val to_string : t -> string
 val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result
+val with_autorelease : (unit -> 'a) -> 'a
+val autorelease : t -> t
+val keep : t -> t
diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml
index af1201b..c1cdfee 100644
--- a/lib/protocols/Relation.ml
+++ b/lib/protocols/Relation.ml
@@ -8,6 +8,7 @@ end
 
 class type implementation = object
   method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+  method modes : (Concepts.Mode.t, Concepts.Condition.condition) result
 end
 
 type Handle.protocol += Relation of implementation
@@ -17,6 +18,7 @@ let make impl = Relation (impl :> implementation)
 let from handle = Handle.into handle (function Relation impl -> Some impl | _ -> None)
 let require handle = from handle |> Option.to_result ~none:(Error.not_a_relation ())
 let contains i tuple = Handle.invoke i (fun o -> o#contains tuple)
+let modes i = Handle.invoke i (fun o -> o#modes)
 
 let heading relation =
   let open Utilities.Result in
diff --git a/lib/protocols/Relation.mli b/lib/protocols/Relation.mli
index 47d1d3e..28dfdff 100644
--- a/lib/protocols/Relation.mli
+++ b/lib/protocols/Relation.mli
@@ -2,12 +2,14 @@ type t
 
 class type implementation = object
   method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+  method modes : (Concepts.Mode.t, Concepts.Condition.condition) result
 end
 
 val make : #implementation -> Handle.protocol
 val from : Handle.t -> t Handle.interface option
 val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
 val contains : t Handle.interface -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+val modes : t Handle.interface -> (Concepts.Mode.t, Concepts.Condition.condition) result
 
 (** the heading a relation describes itself with. *)
 val heading : Handle.t -> (Schematics.relation_description, Concepts.Condition.condition) result