From ce926e575aef7d965895e4443abbf9c13918ebc4 Mon Sep 17 00:00:00 2001
From: Pierre Chambart <pierre.chambart@ocamlpro.com>
Date: Mon, 18 Jun 2018 22:31:32 +0200
Subject: [PATCH] Teamwork: Prevent leaks with never_ending

Lwt_utils.never_ending is a global variable, hence a GC root. A promise
created by binding it cannot ever be garbage collected. This fixes the
known leak in the baker an endorser by allocating a fresh one for each
use (by turning it into a function). This porbably fix other slower
leaks.

High five Klakplok and Vincent.
---
 src/lib_error_monad/error_monad.ml                        | 2 +-
 src/lib_p2p/p2p.ml                                        | 6 +++---
 src/lib_stdlib/lwt_dropbox.ml                             | 2 +-
 src/lib_stdlib/lwt_utils.ml                               | 2 +-
 src/lib_stdlib/lwt_utils.mli                              | 2 +-
 src/proto_alpha/lib_delegate/client_baking_endorsement.ml | 2 +-
 src/proto_alpha/lib_delegate/client_baking_forge.ml       | 2 +-
 7 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml
index ba68e93bd..75c8e418b 100644
--- a/src/lib_error_monad/error_monad.ml
+++ b/src/lib_error_monad/error_monad.ml
@@ -623,7 +623,7 @@ type error += Canceled
 let protect ?on_error ?canceler t =
   let cancelation =
     match canceler with
-    | None -> Lwt_utils.never_ending
+    | None -> Lwt_utils.never_ending ()
     | Some canceler ->
         (Lwt_canceler.cancelation canceler >>= fun () ->
          fail Canceled ) in
diff --git a/src/lib_p2p/p2p.ml b/src/lib_p2p/p2p.ml
index ff214db93..4f3826e91 100644
--- a/src/lib_p2p/p2p.ml
+++ b/src/lib_p2p/p2p.ml
@@ -234,7 +234,7 @@ module Real = struct
         ~f:begin fun _peer_id conn acc ->
           (P2p_pool.is_readable conn >>= function
             | Ok () -> Lwt.return (Some conn)
-            | Error _ -> Lwt_utils.never_ending) :: acc
+            | Error _ -> Lwt_utils.never_ending ()) :: acc
         end in
     Lwt.pick (
       ( P2p_pool.Pool_event.wait_new_connection net.pool >>= fun () ->
@@ -448,8 +448,8 @@ let faked_network peer_cfg faked_metadata = {
   global_stat = (fun () -> Fake.empty_stat) ;
   get_peer_metadata = (fun _ -> peer_cfg.peer_meta_initial) ;
   set_peer_metadata = (fun _ _ -> ()) ;
-  recv = (fun _ -> Lwt_utils.never_ending) ;
-  recv_any = (fun () -> Lwt_utils.never_ending) ;
+  recv = (fun _ -> Lwt_utils.never_ending ()) ;
+  recv_any = (fun () -> Lwt_utils.never_ending ()) ;
   send = (fun _ _ -> fail P2p_errors.Connection_closed) ;
   try_send = (fun _ _ -> false) ;
   fold_connections = (fun ~init ~f:_ -> init) ;
diff --git a/src/lib_stdlib/lwt_dropbox.ml b/src/lib_stdlib/lwt_dropbox.ml
index 2fcbad16f..5b16f7fa6 100644
--- a/src/lib_stdlib/lwt_dropbox.ml
+++ b/src/lib_stdlib/lwt_dropbox.ml
@@ -70,7 +70,7 @@ let rec take dropbox =
       if dropbox.closed then
         Lwt.fail Closed
       else
-        wait_put ~timeout:Lwt_utils.never_ending dropbox >>= fun () ->
+        wait_put ~timeout:(Lwt_utils.never_ending ()) dropbox >>= fun () ->
         take dropbox
 
 let rec take_with_timeout timeout dropbox =
diff --git a/src/lib_stdlib/lwt_utils.ml b/src/lib_stdlib/lwt_utils.ml
index f6ca5cd58..634a6f7ba 100644
--- a/src/lib_stdlib/lwt_utils.ml
+++ b/src/lib_stdlib/lwt_utils.ml
@@ -16,7 +16,7 @@ let may ~f = function
   | None -> Lwt.return_unit
   | Some x -> f x
 
-let never_ending = fst (Lwt.wait ())
+let never_ending () = fst (Lwt.wait ())
 
 type trigger =
   | Absent
diff --git a/src/lib_stdlib/lwt_utils.mli b/src/lib_stdlib/lwt_utils.mli
index 7d0331b49..78bc8ad1c 100644
--- a/src/lib_stdlib/lwt_utils.mli
+++ b/src/lib_stdlib/lwt_utils.mli
@@ -9,7 +9,7 @@
 
 val may: f:('a -> unit Lwt.t) -> 'a option -> unit Lwt.t
 
-val never_ending: 'a Lwt.t
+val never_ending: unit -> 'a Lwt.t
 
 val worker:
   string ->
diff --git a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml
index 1d6f026c8..796135397 100644
--- a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml
+++ b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml
@@ -220,7 +220,7 @@ let prepare_endorsement (cctxt : #Proto_alpha.full) ~(max_past:int64) state bi
 
 let compute_timeout state =
   match state.to_endorse with
-  | [] -> Lwt_utils.never_ending
+  | [] -> Lwt_utils.never_ending ()
   | to_ends ->
       Lwt.choose (List.map (fun to_end -> to_end.timeout) to_ends)
 
diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml
index 715e82cb4..6111317c3 100644
--- a/src/proto_alpha/lib_delegate/client_baking_forge.ml
+++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml
@@ -403,7 +403,7 @@ let compute_timeout { future_slots } =
   match future_slots with
   | [] ->
       (* No slots, just wait for new blocks which will give more info *)
-      Lwt_utils.never_ending
+      Lwt_utils.never_ending ()
   | (timestamp, _) :: _ ->
       match Client_baking_scheduling.sleep_until timestamp with
       | None ->